hdiff output

r33355/alignutils.f90 2017-09-28 12:30:14.675913087 +0100 r33354/alignutils.f90 2017-09-28 12:30:16.247933784 +0100
  1:   1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/GMIN/source/ALIGN/alignutils.f90' in revision 33354
  2: !    Copyright (C) 2017  Matthew Griffiths 
  3: ! 
  4: !    This program is free software; you can redistribute it and/or modify 
  5: !    it under the terms of the GNU General Public License as published by 
  6: !    the Free Software Foundation; either version 2 of the License, or 
  7: !    (at your option) any later version. 
  8: ! 
  9: !    This program is distributed in the hope that it will be useful, 
 10: !    but WITHOUT ANY WARRANTY; without even the implied warranty of 
 11: !    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 12: !    GNU General Public License for more details. 
 13: ! 
 14: !    You should have received a copy of the GNU General Public License along 
 15: !    with this program; if not, write to the Free Software Foundation, Inc., 
 16: !    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 
 17:  
 18: ! Subroutines: 
 19:  
 20: !    ITERATIVEALIGN(COORDSB,COORDSA,NCOORDS,NDEBUG,NBOXLX,NBOXLY,NBOXLZ,NBULKT, & 
 21: !     & DISTANCE,DIST2,RMATBEST,DISPBEST,PERMBEST) 
 22: !        Main alignment algorithm 
 23: !        SAFE TO CALL AS LONG AS NPERMGROUP, NPERMSIZE and PERMGROUP exist 
 24: !        iteratively permutes then moves coordsa to best match coordsb 
 25: !        returns the rotation matrix RMATBEST or displacement vector DISPBEST  that 
 26: !        best maps coordsa onto coordsb along with the permutation PERMBEST 
 27: !        along with the distance DIST2 and the distance squared DISTANCE 
 28:  
 29: !    MINIMISESEPARATION(COORDSB,COORDSA,NCOORDS,DISTANCE,RMATBEST,DISPBEST) 
 30: !        Moves coordsa to best match coordsb 
 31:  
 32: !    FINDROTATION(COORDSB,COORDSA,NCOORDS,DIST,RMAT) 
 33: !        rotates coordsa around the origin to match coordsb 
 34:  
 35: !    FINDDISPLACEMENT(COORDSB,COORDSA,NCOORDS,DIST,DISP) 
 36: !        minimizes the average displacement between points 
 37: !        (whilst applying periodic BC) 
 38:  
 39: !    FINDBESTPERMUTATION(COORDSB,COORDSA,NCOORDS,NEWPERM,DISTANCE,DIST2) 
 40: !        finds the best permutational alignment between coordsa and coordsb 
 41:  
 42: !    PERMPAIRDISTS(COORDSB,COORDSA,NCOORDS,MAXNEI,NDISTS,NIDX,NPERMGROUP) 
 43: !        calculates the value of the distance matrix between coordsa and coordsb 
 44: !        only up to the PMAXNEI nearest neighbour distances are stored 
 45:  
 46: !    FINDBESTPERM(NDISTS,NIDX,NCOORDS,MAXNEI,PERM,DIST,NPERMGROUP,INFO) 
 47: !        solves the permutation problem given the results of PERMPAIRDISTS 
 48:  
 49: !    PAIRDISTS(n, p, q, sx, sy, sz, pbc, cc, kk, maxnei) 
 50: !        calculates the pairwise distance matrix for a homoatomix pair of structures 
 51: !        p and q 
 52:  
 53: !    REALLOCATEARRAYS() 
 54: !        this allocates the arrays needed by the algorithm 
 55:  
 56: !    SETPERM(NEWNATOMS, NEWPERMGROUP, NEWNPERMSIZE) 
 57: !        this allocates the permutation arrays in Commons, not needed in GMIN or OPTIM 
 58:  
 59: !    JOVOSAP(N,SZ,CC,KK,FIRST,X,Y,U,V,H) 
 60: !        this code finds the minimal permutation alignment between two structures, 
 61: !        abandon all hope all ye who enter this code 
 62:  
 63: ! functions: 
 64: !    PAIRDIST(C1, C2) 
 65: !        calculates the distance between points C1 and C2 
 66: !        includes periodic boundary conditions 
 67:  
 68:  
 69: ! INCLUDE "commons.f90" 
 70:  
 71: MODULE ALIGNUTILS 
 72:  
 73: USE COMMONS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM, MYUNIT, & 
 74:  & NSETS, SETS, PERMINVOPT, NOINVERSION, BOXLX, BOXLY, BOXLZ, OHCELLT, TWOD!, PERMDIST, PERMOPT 
 75: USE PREC, ONLY: INT64, REAL64 
 76:  
 77: IMPLICIT NONE 
 78:  
 79: INTEGER, SAVE :: NATOMS, NLAP, NPERM, PATOMS, NTRIES, INFO 
 80: INTEGER, SAVE :: PMAXNEI = 60 
 81: DOUBLE PRECISION, PARAMETER :: PSCALE = 1.D6 ! Scale for linear assignment problem 
 82: INTEGER, PARAMETER :: MAXIMUMTRIES=20 ! Maximum number of iterations 
 83:  
 84: ! Arrays of distances and nearest neighbour distances 
 85: DOUBLE PRECISION, SAVE, ALLOCATABLE :: DUMMYDISTS(:,:), DUMMYNEARDISTS(:) 
 86:  
 87: INTEGER, SAVE, ALLOCATABLE :: DUMMYIDX(:,:) 
 88: INTEGER, SAVE, ALLOCATABLE :: INVPERMGROUP(:) 
 89:  
 90: DOUBLE PRECISION, SAVE :: ROTA(3,3), ROTINVA(3,3), ROTB(3,3), ROTINVB(3,3), ROTINVBBEST(3,3), ROTABEST(3,3), TMAT(3,3) 
 91: DOUBLE PRECISION, SAVE :: CMAX, CMAY, CMAZ, CMBX, CMBY, CMBZ, RMATCUMUL(3,3), RMATNEW(3,3) 
 92: DOUBLE PRECISION, SAVE :: NEWDISTANCE, NEWDIST2, PDIST2 
 93:  
 94: !DOUBLE PRECISION, SAVE :: BOXLY, BOXLY, BOXLZ 
 95: DOUBLE PRECISION, SAVE :: BOXVEC(3), DISPCUMUL(3), DISPNEW(3) 
 96:  
 97: ! Used when solving assignment problem 
 98: DOUBLE PRECISION, SAVE, ALLOCATABLE :: PDUMMYA(:), PDUMMYB(:), DUMMYA(:), & 
 99:     & DUMMYB(:), DUMMY(:) 
100: INTEGER, SAVE, ALLOCATABLE :: NEWPERM(:), LPERM(:), ALLPERM(:), SAVEPERM(:) 
101:  
102: LOGICAL, SAVE :: DEBUG = .TRUE., SAVECOORDS = .TRUE., BULKT 
103:  
104: ! For saving alignments 
105: INTEGER, SAVE :: NSTORED, NSAVE=20 
106: DOUBLE PRECISION, SAVE :: DTOL=1E-3 
107: DOUBLE PRECISION, SAVE, ALLOCATABLE ::  BESTDISTS(:), BESTCOORDS(:,:) 
108: DOUBLE PRECISION, SAVE, ALLOCATABLE ::  BESTRMATS(:,:,:), BESTDISPS(:,:) 
109:  
110: CONTAINS 
111:  
112: SUBROUTINE ITERATIVEALIGN(COORDSB,COORDSA,NCOORDS,NDEBUG,NBOXLX,NBOXLY,NBOXLZ,NBULKT, & 
113:  & DISTANCE,DIST2,RMATBEST,DISPBEST,PERMBEST) 
114:  
115: INTEGER, INTENT(IN) :: NCOORDS 
116: DOUBLE PRECISION, INTENT(IN) :: NBOXLX, NBOXLY, NBOXLZ 
117: LOGICAL, INTENT(IN) :: NDEBUG, NBULKT 
118:  
119: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS) 
120: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2, RMATBEST(3,3), DISPBEST(3) 
121: INTEGER, INTENT(OUT) :: PERMBEST(NCOORDS) 
122:  
123: INTEGER J1, J2, J3 
124:  
125: ! Setting module variables 
126: DEBUG = NDEBUG 
127: BULKT = NBULKT 
128: NATOMS = NCOORDS 
129: BOXLX = NBOXLX; BOXLY = NBOXLY; BOXLZ = NBOXLZ 
130: BOXVEC = (/BOXLX,BOXLY,BOXLZ/) 
131:  
132: CALL REALLOCATEARRAYS() 
133:  
134: IF (BULKT) THEN 
135:     DUMMYA(1:3*NATOMS) = COORDSA(1:3*NATOMS) 
136:     DUMMYB(1:3*NATOMS) = COORDSB(1:3*NATOMS) 
137:  
138:     DISPBEST(1:3) = 0.D0 
139: ELSE 
140:     ! Calculating centres of mass of coordinates 
141:     ! Superimposing centre of mass of COORDSA with COORDSB 
142:     ! Sets centres of mass of both structures to origin 
143:     CMAX=0.0D0; CMAY=0.0D0; CMAZ=0.0D0 
144:     DO J1=1,NATOMS 
145:         CMAX=CMAX+COORDSA(3*(J1-1)+1) 
146:         CMAY=CMAY+COORDSA(3*(J1-1)+2) 
147:         CMAZ=CMAZ+COORDSA(3*(J1-1)+3) 
148:     ENDDO 
149:     CMAX=CMAX/NATOMS; CMAY=CMAY/NATOMS; CMAZ=CMAZ/NATOMS 
150:  
151:     CMBX=0.0D0; CMBY=0.0D0; CMBZ=0.0D0 
152:     DO J1=1,NATOMS 
153:         CMBX=CMBX+COORDSB(3*(J1-1)+1) 
154:         CMBY=CMBY+COORDSB(3*(J1-1)+2) 
155:         CMBZ=CMBZ+COORDSB(3*(J1-1)+3) 
156:     ENDDO 
157:     CMBX=CMBX/NATOMS; CMBY=CMBY/NATOMS; CMBZ=CMBZ/NATOMS 
158:  
159:     DO J1=1,NATOMS 
160:         DUMMYA(3*(J1-1)+1) = COORDSA(3*(J1-1)+1) - CMAX 
161:         DUMMYA(3*(J1-1)+2) = COORDSA(3*(J1-1)+2) - CMAY 
162:         DUMMYA(3*(J1-1)+3) = COORDSA(3*(J1-1)+3) - CMAZ 
163:  
164:         DUMMYB(3*(J1-1)+1) = COORDSB(3*(J1-1)+1) - CMBX 
165:         DUMMYB(3*(J1-1)+2) = COORDSB(3*(J1-1)+2) - CMBY 
166:         DUMMYB(3*(J1-1)+3) = COORDSB(3*(J1-1)+3) - CMBZ 
167:     ENDDO 
168:  
169:     RMATBEST(1:3,1:3) = 0.0D0 
170:     RMATBEST(1,1) = 1.0D0; RMATBEST(2,2) = 1.0D0; RMATBEST(3,3) = 1.0D0 
171: END IF 
172:  
173: DO J1=1,NATOMS 
174: !    BESTPERM(J1)  = J1 
175:     PERMBEST(J1) = J1 
176: !    SAVEPERM(J1) = J1 
177: ENDDO 
178:  
179: NTRIES = 0 
180: NPERM = NCOORDS 
181: DO WHILE(NPERM.GT.0) 
182:  
183:     IF (DEBUG) WRITE(MYUNIT,'(A,I2)') 'alignutils> beginning iteration ', NTRIES+1 
184:  
185:     ! Saving unpermuted coordinates 
186:     DUMMY(1:3*NATOMS) = DUMMYA(1:3*NATOMS) 
187:     SAVEPERM(1:NATOMS) = PERMBEST(1:NATOMS) 
188:  
189:     CALL FINDBESTPERMUTATION(DUMMYB,DUMMYA,NATOMS,NEWPERM,NEWDISTANCE,PDIST2) 
190:  
191:     ! Applying permutation 
192:     NPERM = 0 
193:     DO J1=1,NATOMS 
194:         DUMMYA(3*(J1-1)+1)=DUMMY(3*(NEWPERM(J1)-1)+1) 
195:         DUMMYA(3*(J1-1)+2)=DUMMY(3*(NEWPERM(J1)-1)+2) 
196:         DUMMYA(3*(J1-1)+3)=DUMMY(3*(NEWPERM(J1)-1)+3) 
197:         PERMBEST(J1) = SAVEPERM(NEWPERM(J1)) 
198:         IF (J1.NE.NEWPERM(J1)) THEN 
199:             NPERM=NPERM+1 
200:         ENDIF 
201:     ENDDO 
202:  
203:     IF (DEBUG) WRITE(MYUNIT,'(A,I6,A,G20.10)') & 
204:     & 'alignutils> distance after permuting ',NPERM,' pairs of atoms=', PDIST2 
205:  
206:     CALL MINIMISESEPARATION(DUMMYB,DUMMYA,NATOMS,NEWDIST2,RMATNEW,DISPNEW) 
207:  
208:     IF (DEBUG.AND.BULKT) THEN 
209:         WRITE(MYUNIT,'(A,G20.10)') & 
210:         & 'alignutils> distance after minimising displacement', NEWDIST2 
211:     ELSE IF (DEBUG) THEN 
212:         WRITE(MYUNIT,'(A,G20.10)') & 
213:         & 'alignutils> distance after minimising rotation', NEWDIST2 
214:     ENDIF 
215:  
216:     ! Updating coordinates 
217:     IF (BULKT) THEN 
218:         DISPBEST = DISPBEST + DISPNEW 
219:         DO J1=1,NATOMS 
220:             DUMMYA(3*(J1-1)+1) = COORDSA(3*(PERMBEST(J1)-1)+1) + DISPBEST(1) 
221:             DUMMYA(3*(J1-1)+2) = COORDSA(3*(PERMBEST(J1)-1)+2) + DISPBEST(2) 
222:             DUMMYA(3*(J1-1)+3) = COORDSA(3*(PERMBEST(J1)-1)+3) + DISPBEST(3) 
223:         ENDDO 
224:     ELSE 
225:         RMATBEST = MATMUL(RMATNEW, RMATBEST) 
226:         DO J1=1,NATOMS 
227:             DUMMYA(3*(J1-1)+1) = COORDSA(3*(PERMBEST(J1)-1)+1) - CMAX 
228:             DUMMYA(3*(J1-1)+2) = COORDSA(3*(PERMBEST(J1)-1)+2) - CMAY 
229:             DUMMYA(3*(J1-1)+3) = COORDSA(3*(PERMBEST(J1)-1)+3) - CMAZ 
230:  
231:             DUMMYA(3*J1-2:3*J1) = MATMUL(RMATBEST, DUMMYA(3*J1-2:3*J1)) 
232:         ENDDO 
233:     ENDIF 
234:  
235:     NTRIES = NTRIES + 1 
236:  
237:     IF (((NEWDIST2-PDIST2)/NEWDIST2).GT.(SQRT(1.D0*NCOORDS)/PSCALE)) THEN 
238:         IF (DEBUG) WRITE(MYUNIT, '(A)') 'alignutils> WARNING - distance increased with nonzero permutations' 
239:         EXIT 
240:     ENDIF 
241:     IF (NTRIES.GT.MAXIMUMTRIES) THEN 
242:         IF (DEBUG) WRITE(MYUNIT, '(A)') 'alignutils> WARNING - number of tries exceeded' 
243:         EXIT 
244:     ENDIF 
245: ENDDO 
246:  
247: ! Assigning solution to COORDSA 
248: IF (BULKT) THEN 
249:     COORDSA(1:3*NATOMS) = DUMMYA(1:3*NATOMS) 
250: ELSE 
251:     COORDSA(1:3*NATOMS-2:3) = DUMMYA(1:3*NATOMS-2:3) + CMBX 
252:     COORDSA(2:3*NATOMS-1:3) = DUMMYA(2:3*NATOMS-1:3) + CMBY 
253:     COORDSA(3:3*NATOMS  :3) = DUMMYA(3:3*NATOMS  :3) + CMBZ 
254: ENDIF 
255:  
256: DISTANCE = NEWDIST2**2 
257: DIST2 = NEWDIST2 
258:  
259: IF (SAVECOORDS) CALL ADDCOORDS(COORDSA, NATOMS, BULKT, DIST2, RMATBEST, DISPBEST) 
260:  
261: IF (DEBUG) THEN 
262:     WRITE(MYUNIT, '(A,G20.10,A,I2,A)') 'alignutils> best distance found=', NEWDIST2, ' after ', NTRIES, ' iterations' 
263:     IF (BULKT) THEN 
264:         WRITE(MYUNIT, '(A)') 'alignutils> best displacement found:' 
265:         WRITE(MYUNIT, '(3G20.10)') DISPBEST(1:3) 
266:     ELSE 
267:         WRITE(MYUNIT, '(A)') 'alignutils> best rotation found:' 
268:         WRITE(MYUNIT, '(3G20.10)') RMATBEST(1:3,1:3) 
269:     ENDIF 
270: ENDIF 
271:  
272: END SUBROUTINE ITERATIVEALIGN 
273:  
274: SUBROUTINE MINIMISESEPARATION(COORDSB,COORDSA,NCOORDS,DISTANCE,RMATBEST,DISPBEST) 
275:  
276: IMPLICIT NONE 
277: INTEGER, INTENT(IN) :: NCOORDS 
278: DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS) 
279:  
280: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, RMATBEST(3,3), DISPBEST(3) 
281:  
282: IF (BULKT) THEN 
283:     CALL FINDDISPLACEMENT(COORDSB,COORDSA,NCOORDS,DISTANCE,DISPBEST) 
284: ELSE 
285:     CALL FINDROTATION(COORDSB,COORDSA,NCOORDS,DISTANCE,RMATBEST) 
286: ENDIF 
287:  
288: END SUBROUTINE MINIMISESEPARATION 
289:  
290: SUBROUTINE FINDROTATION(COORDSB,COORDSA,NCOORDS,DIST,RMAT) 
291: ! Finds the rotation that minimises the Euclidean distance between 
292: ! COORDSA onto COORDSB around the origin 
293:  
294: IMPLICIT NONE 
295: INTEGER, INTENT(IN) :: NCOORDS 
296: DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS) 
297:  
298: DOUBLE PRECISION, INTENT(OUT) :: RMAT(3,3), DIST 
299:  
300: INTEGER, PARAMETER :: LWORK=12 
301: INTEGER J1, JMIN, INFO 
302: DOUBLE PRECISION QMAT(4,4), MINV, DIAG(4), TEMPA(LWORK), XM, YM, ZM, XP, YP, ZP 
303: DOUBLE PRECISION Q1, Q2, Q3, Q4 
304:  
305: !  The formula below is not invariant to overall translation because XP, YP, ZP 
306: !  involve a sum of coordinates! We need to have COORDSA and COORDSB coordinate 
307: !  centres both at the origin!! 
308:  
309: QMAT(1:4,1:4)=0.0D0 
310: DO J1=1,NCOORDS 
311:       XM=COORDSB(3*(J1-1)+1)-COORDSA(3*(J1-1)+1) 
312:       YM=COORDSB(3*(J1-1)+2)-COORDSA(3*(J1-1)+2) 
313:       ZM=COORDSB(3*(J1-1)+3)-COORDSA(3*(J1-1)+3) 
314:       XP=COORDSB(3*(J1-1)+1)+COORDSA(3*(J1-1)+1) 
315:       YP=COORDSB(3*(J1-1)+2)+COORDSA(3*(J1-1)+2) 
316:       ZP=COORDSB(3*(J1-1)+3)+COORDSA(3*(J1-1)+3) 
317:       QMAT(1,1)=QMAT(1,1)+XM**2+YM**2+ZM**2 
318:       QMAT(1,2)=QMAT(1,2)+YP*ZM-YM*ZP 
319:       QMAT(1,3)=QMAT(1,3)+XM*ZP-XP*ZM 
320:       QMAT(1,4)=QMAT(1,4)+XP*YM-XM*YP 
321:       QMAT(2,2)=QMAT(2,2)+YP**2+ZP**2+XM**2 
322:       QMAT(2,3)=QMAT(2,3)+XM*YM-XP*YP 
323:       QMAT(2,4)=QMAT(2,4)+XM*ZM-XP*ZP 
324:       QMAT(3,3)=QMAT(3,3)+XP**2+ZP**2+YM**2 
325:       QMAT(3,4)=QMAT(3,4)+YM*ZM-YP*ZP 
326:       QMAT(4,4)=QMAT(4,4)+XP**2+YP**2+ZM**2 
327: ENDDO 
328:  
329: QMAT(2,1)=QMAT(1,2); QMAT(3,1)=QMAT(1,3); QMAT(3,2)=QMAT(2,3) 
330: QMAT(4,1)=QMAT(1,4); QMAT(4,2)=QMAT(2,4); QMAT(4,3)=QMAT(3,4) 
331:  
332: CALL DSYEV('V','U',4,QMAT,4,DIAG,TEMPA,LWORK,INFO) 
333: IF (INFO.NE.0) WRITE(MYUNIT,'(A,I6,A)') 'alignutils> FINDROTATION WARNING - INFO=',INFO,' in DSYEV' 
334:  
335: MINV=1.0D100 
336: DO J1=1,4 
337:     IF (DIAG(J1).LT.MINV) THEN 
338:     JMIN=J1 
339:     MINV=DIAG(J1) 
340:     ENDIF 
341: ENDDO 
342: IF (MINV.LT.0.0D0) THEN 
343:     IF (ABS(MINV).LT.1.0D-6) THEN 
344:         MINV=0.0D0 
345:     ELSE 
346:         WRITE(MYUNIT,'(A,G20.10,A)') 'alignutils> FINDROTATION WARNING MINV is ',MINV,' change to absolute value' 
347:         MINV=-MINV 
348:     ENDIF 
349: ENDIF 
350: DIST=SQRT(MINV) 
351:  
352: !IF (DEBUG) WRITE(MYUNIT,'(A,G20.10,A,I6)') 'alignutils> minimum residual is ',DIAG(JMIN),' for eigenvector ',JMIN 
353: Q1=QMAT(1,JMIN); Q2=QMAT(2,JMIN); Q3=QMAT(3,JMIN); Q4=QMAT(4,JMIN) 
354:  
355: RMAT(1,1)=Q1**2+Q2**2-Q3**2-Q4**2 
356: RMAT(1,2)=2*(Q2*Q3+Q1*Q4) 
357: RMAT(1,3)=2*(Q2*Q4-Q1*Q3) 
358: RMAT(2,1)=2*(Q2*Q3-Q1*Q4) 
359: RMAT(2,2)=Q1**2+Q3**2-Q2**2-Q4**2 
360: RMAT(2,3)=2*(Q3*Q4+Q1*Q2) 
361: RMAT(3,1)=2*(Q2*Q4+Q1*Q3) 
362: RMAT(3,2)=2*(Q3*Q4-Q1*Q2) 
363: RMAT(3,3)=Q1**2+Q4**2-Q2**2-Q3**2 
364:  
365: END SUBROUTINE FINDROTATION 
366:  
367: SUBROUTINE FINDDISPLACEMENT(COORDSB,COORDSA,NCOORDS,DIST,DISP) 
368:  
369: IMPLICIT NONE 
370: INTEGER, INTENT(IN) :: NCOORDS 
371: DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS) 
372:  
373: DOUBLE PRECISION, INTENT(OUT) :: DISP(3), DIST 
374:  
375: INTEGER J1 
376: DOUBLE PRECISION XM, YM, ZM 
377:  
378: ! Calculate average displacement 
379: DO J1=1,NCOORDS 
380:     XM = COORDSB(3*J1-2) - COORDSA(3*J1-2) 
381:     YM = COORDSB(3*J1-1) - COORDSA(3*J1-1) 
382:     DISP(1) = DISP(1) + XM - BOXLX*NINT(XM/BOXLX) 
383:     DISP(2) = DISP(2) + YM - BOXLY*NINT(YM/BOXLY) 
384: ENDDO 
385:  
386: IF (TWOD) THEN 
387:     DISP(3) = 0.D0 
388: ELSE 
389:     DO J1=1,NCOORDS 
390:         ZM = COORDSB(3*J1  ) - COORDSA(3*J1  ) 
391:         DISP(3) = DISP(3) + ZM - BOXLZ*NINT(ZM/BOXLZ) 
392:     ENDDO 
393: END IF 
394:  
395: DISP = DISP/NCOORDS 
396:  
397: ! Calculate new distance 
398: DIST = 0.D0 
399: DO J1=1,NCOORDS 
400:     DIST = DIST + PAIRDIST(COORDSB(3*J1-2:3*J1),COORDSA(3*J1-2:3*J1)+DISP) 
401: ENDDO 
402: DIST = SQRT(DIST) 
403:  
404: END SUBROUTINE FINDDISPLACEMENT 
405:  
406: SUBROUTINE FINDBESTPERMUTATION(COORDSB,COORDSA,NCOORDS,NEWPERM,DISTANCE,DIST2) 
407:  
408: IMPLICIT NONE 
409: INTEGER, INTENT(IN) :: NCOORDS 
410: DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS) 
411:  
412: INTEGER, INTENT(OUT) :: NEWPERM(NCOORDS) 
413: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2 
414:  
415: CALL PERMPAIRDISTS(COORDSB,COORDSA,NCOORDS,PMAXNEI,DUMMYDISTS,DUMMYIDX,NPERMGROUP) 
416: CALL FINDBESTPERM(DUMMYDISTS,DUMMYIDX,NCOORDS,PMAXNEI,NEWPERM,DISTANCE,NPERMGROUP,INFO) 
417:  
418: DIST2 = SQRT(DISTANCE) 
419:  
420: IF ((INFO.GT.0).AND.DEBUG) WRITE(MYUNIT, "(A,I3)") & 
421:  & "alignutils> WARNING LAP algorithm failed to align npoints= ", INFO 
422:  
423: END SUBROUTINE FINDBESTPERMUTATION 
424:  
425: SUBROUTINE PERMPAIRDISTS(COORDSB,COORDSA,NCOORDS,MAXNEI,NDISTS,NIDX,NPERMGROUP) 
426:  
427: ! Calculates the maxtrix of closest distances between COORDSB and COORDSA 
428: ! Only stores up to MAXNEI nearest neighbours 
429: ! NIDX returns the indexes of the nearest neighbour distances, contained in NDISTS 
430: ! Uses module variables BOXLX, BOXLY, BOXLZ, BULKT when calculating periodic distances 
431:  
432: IMPLICIT NONE 
433:  
434: INTEGER, INTENT(IN) :: NCOORDS, NPERMGROUP, MAXNEI 
435: DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS) 
436:  
437: INTEGER, INTENT(OUT) :: NIDX(MAXNEI*NCOORDS,NPERMGROUP) 
438: DOUBLE PRECISION, INTENT(OUT) :: NDISTS(MAXNEI*NCOORDS,NPERMGROUP) 
439:  
440: INTEGER NDUMMY,J1,J2,NPERM 
441:  
442: NATOMS = NCOORDS 
443: NATOMS = SUM(NPERMSIZE(1:NPERMGROUP)) 
444: CALL REALLOCATEARRAYS() 
445:  
446: NDUMMY = 0 
447:  
448: NIDX   = -1 
449: NDISTS = HUGE(1.D0) 
450:  
451:  
452: DO J1=1,NPERMGROUP 
453:     NPERM=NPERMSIZE(J1) 
454:     DO J2=1,NPERM 
455:         PDUMMYA(3*(J2-1)+1)=COORDSA(3*((PERMGROUP(NDUMMY+J2))-1)+1) 
456:         PDUMMYA(3*(J2-1)+2)=COORDSA(3*((PERMGROUP(NDUMMY+J2))-1)+2) 
457:         PDUMMYA(3*(J2-1)+3)=COORDSA(3*((PERMGROUP(NDUMMY+J2))-1)+3) 
458:         PDUMMYB(3*(J2-1)+1)=COORDSB(3*((PERMGROUP(NDUMMY+J2))-1)+1) 
459:         PDUMMYB(3*(J2-1)+2)=COORDSB(3*((PERMGROUP(NDUMMY+J2))-1)+2) 
460:         PDUMMYB(3*(J2-1)+3)=COORDSB(3*((PERMGROUP(NDUMMY+J2))-1)+3) 
461:     ENDDO 
462:     CALL PAIRDISTS(NPERM,PDUMMYB(1:3*NPERM),PDUMMYA(1:3*NPERM),BOXLX,BOXLY, & 
463:  & BOXLZ,BULKT,NDISTS(1:MAXNEI*NPERM,J1),NIDX(1:MAXNEI*NPERM,J1),MAXNEI) 
464:     NDUMMY = NDUMMY + NPERM 
465: ENDDO 
466:  
467: END SUBROUTINE PERMPAIRDISTS 
468:  
469: SUBROUTINE FINDBESTPERM(NDISTS,NIDX,NCOORDS,MAXNEI,PERM,DIST,NPERMGROUP,INFO) 
470:  
471: ! Solves assignment problem using the shortest augmenting path algorithm: 
472: ! Jonker, R., & Volgenant, A. (1987). 
473: ! A shortest augmenting path algorithm for dense and sparse linear assignment problems. 
474: ! Computing, 38(4), 325–340. http://doi.org/10.1007/BF02278710 
475:  
476: ! This calculates the exact distance as well! 
477:  
478: ! Code copied from GMIN/source/minperm.f90 
479:  
480: IMPLICIT NONE 
481:  
482: INTEGER, INTENT(IN) :: NCOORDS,NPERMGROUP,MAXNEI,NIDX(MAXNEI*NCOORDS,NPERMGROUP) 
483: DOUBLE PRECISION, INTENT(IN) :: NDISTS(MAXNEI*NCOORDS,NPERMGROUP) 
484:  
485: DOUBLE PRECISION, INTENT(OUT) :: DIST 
486: INTEGER, INTENT(OUT) :: PERM(NCOORDS), INFO 
487:  
488: ! COULD SET THESE AS MODULE VARIABLES 
489: INTEGER(KIND=INT64) :: KK(NCOORDS*MAXNEI), CC(NCOORDS*MAXNEI) 
490: INTEGER(KIND=INT64) :: FIRST(NCOORDS+1), X(NCOORDS), Y(NCOORDS) 
491: INTEGER(KIND=INT64) :: U(NCOORDS), V(NCOORDS), N8, SZ8, H 
492: !INTEGER(KIND=INT64) :: KK(NATOMS*MAXNEI), CC(NATOMS*MAXNEI) 
493: !INTEGER(KIND=INT64) :: FIRST(NATOMS+1), X(NATOMS), Y(NATOMS) 
494: !INTEGER(KIND=INT64) :: U(NATOMS), V(NATOMS), N8, SZ8, H 
495: INTEGER N,M,I,J,K,K1,I1,J1,J2,NDUMMY 
496:  
497: DOUBLE PRECISION D2 
498:  
499: NATOMS = NCOORDS 
500: CALL REALLOCATEARRAYS() 
501:  
502: D2=0.D0 
503: DIST=0.D0 
504: INFO=0 
505:  
506: NDUMMY=0 
507:  
508: DO J1=1,NPERMGROUP 
509:  
510:     N = NPERMSIZE(J1) 
511:     M = MAXNEI 
512:     IF(N.LE.MAXNEI) M=N 
513:     SZ8 = M*N 
514:     N8 = N 
515:  
516:     DO I=0,N 
517:         FIRST(I+1) = I*M +1 
518:     ENDDO 
519:     KK = -1 
520:     CC = HUGE(1) 
521:     DO J=1,N 
522:         K = FIRST(J)-1 
523:         DO I=1,M 
524:             KK(I+K) = NIDX(I+K,J1) 
525:             CC(I+K) = INT(NDISTS(I+K,J1)*PSCALE, 8) 
526:         ENDDO 
527:     ENDDO 
528:  
529:     ! Solving the assignment problem to deduce the correct permutation 
530:     CALL JOVOSAP(N8, SZ8, CC(:M*N), KK(:M*N), FIRST(:N+1), Y(:N), X(:N), U(:N), V(:N), H) 
531:     NLAP = NLAP + 1 
532:  
533:     DO J=1,N 
534:         IF (Y(J).GT.N) THEN 
535:             Y(J)=N 
536:             INFO = INFO + 1 
537:         END IF 
538:         IF (Y(J).LT.1) THEN 
539:             Y(J)=1 
540:             INFO = INFO + 1 
541:         END IF 
542:         PERM(PERMGROUP(NDUMMY+J)) = PERMGROUP(NDUMMY+Y(J)) 
543:  
544:         ! Calculating exact distance 
545:         K = FIRST(J)-1 
546:         J2 = MIN(Y(J),M) 
547:         IF (Y(J).NE.NIDX(J2+K,J1)) THEN 
548:             DO J2=1,M !If N>MAXNEI then we must search the list 
549:                 IF (Y(J).EQ.NIDX(J2+K,J1)) EXIT 
550:             ENDDO 
551:         END IF 
552:         DIST = DIST + NDISTS(J2+K,J1) 
553:     ENDDO 
554:  
555:     ! untested!! 
556:     IF (NSETS(J1).GT.0) THEN 
557:         DO I=1,N 
558:             DO K=1,NSETS(J1) 
559:                 PERM(SETS(PERMGROUP(NDUMMY+I),K))=SETS(PERM(PERMGROUP(NDUMMY+Y(I))),K) 
560:             ENDDO 
561:         ENDDO 
562:     ENDIF 
563:  
564:     NDUMMY = NDUMMY + NPERMSIZE(J1) 
565: ENDDO 
566:  
567: END SUBROUTINE FINDBESTPERM 
568:  
569: SUBROUTINE PAIRDISTS(n, p, q, sx, sy, sz, pbc, cc, kk, maxnei) 
570:       implicit none 
571:  
572: !     Input 
573: !       n  : System size 
574: !       p,q: Coordinate vectors (n particles) 
575: !       s  : Box lengths (or dummy if open B.C.) 
576: !       pbc: Periodic boundary conditions? 
577:       integer, intent(in) :: n, maxnei 
578:       double precision, intent(in) :: p(3*n), q(3*n), sx, sy, sz 
579:       logical, intent(in) :: pbc 
580:       double precision s(3) 
581:  
582: !     Output 
583: !       perm: Permutation so that p(i) <--> q(perm(i)) 
584: !       dist: Minimum attainable distance 
585: !     We have 
586:       double precision, intent(out) :: cc(n*maxnei) 
587:       integer, intent(out) :: kk(n*maxnei) 
588:       double precision DUMMY 
589:  
590: !     Parameters 
591: !       scale : Precision 
592: !       maxnei: Maximum number of closest neighbourspa 
593:       double precision scale, d, h 
594:  
595:       parameter (scale = 1.0d6   ) 
596: !      parameter (maxnei = 60     ) 
597:  
598:       INTEGER(KIND=INT64) first(n+1)!, x(n), y(n) 
599: !      INTEGER(KIND=INT64) u(n), v(n) 
600:       integer   m, i, j, k, l, l2, t, a 
601:       INTEGER(KIND=INT64) n8, sz8 
602:       integer J1 
603:  
604:       BOXVEC = (/sx,sy,sz/) 
605:       s(1)=sx 
606:       s(2)=sy 
607:       s(3)=sz 
608:       m = maxnei 
609:       if(n .le. maxnei) m = n 
610:       sz8 = m*n 
611:       n8 = n 
612:  
613:       do i=0,n 
614:          first(i+1) = i*m + 1 
615:       enddo 
616:  
617:       if(m .eq. n) then 
618: !     Compute the full matrix... 
619:          do i=1,n 
620:             k = first(i)-1 
621:             do j=1,n 
622:                cc(k+j) = PAIRDIST(p(3*i-2), q(3*j-2)) 
623:                kk(k+j) = j 
624: !              write(*,*) i, j, '-->', cc(k+j) 
625:             enddo 
626:          enddo 
627:       else 
628: !     We need to store the distances of the maxnei closeest neighbors 
629: !     of each particle. The following builds a heap to keep track of 
630: !     the maxnei closest neighbours seen so far. It might be more 
631: !     efficient to use quick-select instead... (This is definitely 
632: !     true in the limit of infinite systems.) 
633:         do i=1,n 
634:            k = first(i)-1 
635:            do j=1,m 
636:               cc(k+j) = PAIRDIST(p(3*i-2), q(3*j-2)) 
637:               kk(k+j) = j 
638:               l = j 
639: 10            if(l .le. 1) goto 11 
640:               l2 = l/2 
641:               if(cc(k+l2) .lt. cc(k+l)) then 
642:                  h = cc(k+l2) 
643:                  cc(k+l2) = cc(k+l) 
644:                  cc(k+l) = h 
645:                  t = kk(k+l2) 
646:                  kk(k+l2) = kk(k+l) 
647:                  kk(k+l) = t 
648:                  l = l2 
649:                  goto 10 
650:               endif 
651: 11         enddo 
652:  
653:            do j=m+1,n 
654:               d = PAIRDIST(p(3*i-2), q(3*j-2)) 
655:               if(d .lt. cc(k+1)) then 
656:                  cc(k+1) = d 
657:                  kk(k+1) = j 
658:                  l = 1 
659: 20               l2 = 2*l 
660:                  if(l2+1 .gt. m) goto 21 
661:                  if(cc(k+l2+1) .gt. cc(k+l2)) then 
662:                     a = k+l2+1 
663:                  else 
664:                     a = k+l2 
665:                  endif 
666:                  if(cc(a) .gt. cc(k+l)) then 
667:                     h = cc(a) 
668:                     cc(a) = cc(k+l) 
669:                     cc(k+l) = h 
670:                     t = kk(a) 
671:                     kk(a) = kk(k+l) 
672:                     kk(k+l) = t 
673:                     l = a-k 
674:                     goto 20 
675:                  endif 
676: 21               if (l2 .le. m) THEN ! split IF statements to avoid a segmentation fault 
677:                     IF (cc(k+l2) .gt. cc(k+l)) then 
678:                        h = cc(k+l2) 
679:                        cc(k+l2) = cc(k+l) 
680:                        cc(k+l) = h 
681:                        t = kk(k+l2) 
682:                        kk(k+l2) = kk(k+l) 
683:                        kk(k+l) = t 
684:                     ENDIF 
685:                  endif 
686:               endif 
687:            enddo 
688:         enddo 
689:       ENDIF 
690:  
691: END SUBROUTINE PAIRDISTS 
692:  
693: FUNCTION PAIRDIST(C1, C2) RESULT(DIST) 
694:  
695: ! Calculates distance^2 between points C1 and C2 
696: ! Requires BULKT and BOXVEC variables to be set 
697:  
698: IMPLICIT NONE 
699: DOUBLE PRECISION, INTENT(IN) :: C1(3), C2(3) 
700: DOUBLE PRECISION T, DIST 
701:  
702: INTEGER I 
703:  
704: DIST=0.D0 
705: IF (BULKT) THEN 
706:     DO I=1,3 
707:         IF (BOXVEC(I).NE.0.0D0) THEN 
708:             T = C1(i) - C2(i) 
709:             T = T - BOXVEC(i)*anint(T/BOXVEC(I)) 
710:             DIST = DIST + T*T 
711:         ENDIF 
712:     ENDDO 
713: ELSE 
714:     DIST = (C1(1) - C2(1))**2+(C1(2) - C2(2))**2+(C1(3) - C2(3))**2 
715: ENDIF 
716:  
717: END FUNCTION PAIRDIST 
718:  
719: SUBROUTINE REALLOCATEARRAYS() 
720:  
721: IMPLICIT NONE 
722:  
723: IF((.NOT.ALLOCATED(PERMGROUP)).OR.(.NOT.ALLOCATED(NPERMSIZE))) THEN 
724:     WRITE(*,'(A)') 'ERROR - permutation arrays not set, use PERMOPT keyword' 
725:     STOP 
726: ENDIF 
727:  
728: IF (SIZE(DUMMYDISTS).NE.(PMAXNEI*NATOMS*NPERMGROUP)) THEN 
729:     IF (DEBUG) WRITE(MYUNIT,"(A)") 'alignutils> reallocating distance arrays' 
730:     IF(ALLOCATED(DUMMYDISTS)) DEALLOCATE(DUMMYDISTS,DUMMYNEARDISTS, & 
731:      & DUMMYIDX) 
732:     ALLOCATE(DUMMYDISTS(PMAXNEI*NATOMS,NPERMGROUP),DUMMYNEARDISTS(NATOMS), & 
733:      & DUMMYIDX(PMAXNEI*NATOMS,NPERMGROUP)) 
734: END IF 
735:  
736: IF (SIZE(LPERM).NE.NATOMS) THEN 
737:     IF (DEBUG) WRITE(MYUNIT,"(A)") 'alignutils> reallocating coordinate arrays' 
738:     IF(ALLOCATED(PDUMMYA)) DEALLOCATE(PDUMMYA,PDUMMYB,DUMMYA,DUMMYB) 
739:     IF(ALLOCATED(NEWPERM)) DEALLOCATE(NEWPERM,LPERM,ALLPERM,SAVEPERM,INVPERMGROUP,DUMMY) 
740:     ALLOCATE(PDUMMYA(3*NATOMS),PDUMMYB(3*NATOMS),DUMMYA(3*NATOMS),DUMMY(3*NATOMS), & 
741:      & DUMMYB(3*NATOMS),NEWPERM(NATOMS),LPERM(NATOMS),SAVEPERM(NATOMS), & 
742:      & ALLPERM(NATOMS),INVPERMGROUP(NATOMS)) 
743: END IF 
744:  
745: IF (SAVECOORDS.AND.(SIZE(BESTCOORDS).NE.(NSAVE*NATOMS*3))) THEN 
746:     IF (DEBUG) WRITE(MYUNIT, "(A,I3,A)") "alignutils> reallocating arrays to save ", NSAVE, " coordinates" 
747:     NSTORED = 0 
748:     IF (ALLOCATED(BESTDISTS)) DEALLOCATE(BESTDISTS,BESTCOORDS,BESTRMATS,BESTDISPS) 
749:     ALLOCATE(BESTDISTS(NSAVE),BESTCOORDS(3*NATOMS,NSAVE),BESTRMATS(3,3,NSAVE),BESTDISPS(3,NSAVE)) 
750: END IF 
751:  
752: END SUBROUTINE REALLOCATEARRAYS 
753:  
754: SUBROUTINE DEALLOCATEALIGNUTILS() 
755:  
756: IMPLICIT NONE 
757: IF (ALLOCATED(DUMMYDISTS)) DEALLOCATE(DUMMYDISTS,DUMMYNEARDISTS, & 
758:      & DUMMYIDX) 
759: IF (ALLOCATED(PDUMMYA)) DEALLOCATE(PDUMMYA,PDUMMYB,DUMMYA,DUMMYB) 
760: IF (ALLOCATED(NEWPERM)) DEALLOCATE(NEWPERM,LPERM,ALLPERM,SAVEPERM,INVPERMGROUP,DUMMY) 
761: IF (ALLOCATED(BESTDISTS)) DEALLOCATE(BESTDISTS,BESTCOORDS,BESTRMATS,BESTDISPS) 
762:  
763: END SUBROUTINE DEALLOCATEALIGNUTILS 
764:  
765: SUBROUTINE SETPERM(NEWNATOMS, NEWPERMGROUP, NEWNPERMSIZE) 
766: ! Not needed for GMIN/OPTIM/PATHSAMPLE 
767: ! (Re)allocates arrays that define allowed permuations 
768: IMPLICIT NONE 
769:  
770: INTEGER, INTENT(IN) :: NEWNATOMS, NEWPERMGROUP(:), NEWNPERMSIZE(:) 
771:  
772: IF(.NOT.SIZE(PERMGROUP).EQ.SIZE(NEWPERMGROUP)) THEN 
773:     IF(ALLOCATED(PERMGROUP)) THEN 
774:         DEALLOCATE(PERMGROUP) 
775:     ENDIF 
776:     ALLOCATE(PERMGROUP(SIZE(NEWPERMGROUP))) 
777: ENDIF 
778:  
779: NPERMGROUP = SIZE(NEWNPERMSIZE) 
780: IF(.NOT.SIZE(NPERMSIZE).EQ.SIZE(NEWNPERMSIZE)) THEN 
781:     IF(ALLOCATED(NPERMSIZE)) THEN 
782:         DEALLOCATE(NPERMSIZE) 
783:     ENDIF 
784:     ALLOCATE(NPERMSIZE(NPERMGROUP)) 
785: ENDIF 
786:  
787: IF(.NOT.SIZE(BESTPERM).EQ.NEWNATOMS) THEN 
788:     IF(ALLOCATED(BESTPERM)) THEN 
789:         DEALLOCATE(BESTPERM) 
790:     ENDIF 
791:     ALLOCATE(BESTPERM(NEWNATOMS)) 
792: ENDIF 
793:  
794: IF(.NOT.SIZE(NSETS).EQ.(3*NEWNATOMS)) THEN 
795:     IF(ALLOCATED(NSETS)) THEN 
796:         DEALLOCATE(NSETS) 
797:     ENDIF 
798:     ALLOCATE(NSETS(3*NEWNATOMS)) 
799: ENDIF 
800:  
801: IF(.NOT.SIZE(SETS).EQ.(3*NEWNATOMS*70)) THEN 
802:     IF(ALLOCATED(SETS)) THEN 
803:         DEALLOCATE(SETS) 
804:     ENDIF 
805:     ALLOCATE(SETS(3*NEWNATOMS,70)) 
806: ENDIF 
807:  
808: NATOMS = NEWNATOMS 
809: PERMGROUP = NEWPERMGROUP 
810: NPERMSIZE = NEWNPERMSIZE 
811: NSETS = 0 
812:  
813: CALL REALLOCATEARRAYS() 
814:  
815: END SUBROUTINE SETPERM 
816:  
817: SUBROUTINE OHOPS(X,Y,OPNUM,NLOCAL) 
818: IMPLICIT NONE 
819: INTEGER OPNUM, J2, J3, NLOCAL 
820: DOUBLE PRECISION RMAT(3,3,48), X(3*NLOCAL), Y(3*NLOCAL) 
821: DATA RMAT / & 
822:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
823:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
824:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
825:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
826:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
827:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
828:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
829:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
830:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
831:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
832:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
833:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
834:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
835:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
836:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
837:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
838:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
839:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
840:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
841:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
842:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
843:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
844:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
845:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
846:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
847:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
848:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
849:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
850:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
851:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
852:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
853:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
854:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
855:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
856:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
857:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
858:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
859:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
860:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
861:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
862:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
863:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
864:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
865:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
866:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
867:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
868:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
869:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
870:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
871:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
872:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
873:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
874:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
875:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
876:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
877:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
878:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
879:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
880:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
881:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
882:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
883:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
884:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
885:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
886:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
887:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
888:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
889:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
890:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
891:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
892:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
893:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
894:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
895:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
896:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
897:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
898:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
899:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
900:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
901:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
902:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
903:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
904:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
905:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
906:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
907:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
908:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
909:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
910:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
911:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
912:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
913:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
914:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
915:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
916:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
917:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
918:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
919:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
920:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
921:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
922:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
923:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
924:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
925:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
926:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
927:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
928:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
929:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
930:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
931:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
932:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
933:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
934:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
935:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
936:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
937:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
938:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
939:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
940:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
941:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
942:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
943:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
944:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
945:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
946:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
947:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
948:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
949:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
950:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
951:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
952:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
953:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
954:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
955:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
956:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
957:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
958:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
959:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
960:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
961:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
962:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
963:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
964:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
965:  & 0.0D0,  0.0D0,  1.00000000000D0 / 
966:  
967: DO J2=1,NLOCAL 
968:    J3=3*(J2-1) 
969:    Y(J3+1)=RMAT(1,1,OPNUM)*X(J3+1)+RMAT(1,2,OPNUM)*X(J3+2)+RMAT(1,3,OPNUM)*X(J3+3) 
970:    Y(J3+2)=RMAT(2,1,OPNUM)*X(J3+1)+RMAT(2,2,OPNUM)*X(J3+2)+RMAT(2,3,OPNUM)*X(J3+3) 
971:    Y(J3+3)=RMAT(3,1,OPNUM)*X(J3+1)+RMAT(3,2,OPNUM)*X(J3+2)+RMAT(3,3,OPNUM)*X(J3+3) 
972: ENDDO 
973:  
974: END SUBROUTINE OHOPS 
975:  
976: SUBROUTINE JOVOSAP(N,SZ,CC,KK,FIRST,X,Y,U,V,H) 
977:       IMPLICIT NONE 
978:       INTEGER(KIND=INT64), INTENT(IN)  :: N, SZ 
979:       INTEGER(KIND=INT64), INTENT(IN)  :: CC(SZ),KK(SZ),FIRST(N+1) 
980:       INTEGER(KIND=INT64), INTENT(OUT) :: X(N),Y(N),U(N),V(N),H 
981:       INTEGER(KIND=INT64) CNT,L0,T,T0,TD,V0,VJ,DJ 
982:       INTEGER(KIND=INT64) LAB(N),D(N),FREE(N),TODO(N) 
983:       LOGICAL OK(N) 
984:       INTEGER(KIND=INT64) J, I, J0, L, J1, MIN, K, I0 
985:       INTEGER(KIND=INT64) BIGINT 
986:       J1 = -1 
987:       J0 = -1 
988:  
989: !     I don't know how to make g77 read INTEGER(KIND=INT64) constants/parameters. 
990: !       PARAMETER (BIGINT = 10**12) does not work(!) 
991: !     nor does 
992: !       PARAMETER (BIGINT = 1000000000000) 
993: !     but this seems to be ok: 
994:       BIGINT = 10**9 
995:       BIGINT = BIGINT * 1000 
996:  
997: ! 
998: ! THIS SUBROUTINE SOLVES THE SPARSE LINEAR ASSIGNMENT PROBLEM 
999: ! ACCORDING 
1000: ! 
1001: !   "A Shortest Augmenting Path Algorithm for Dense and Sparse Linear 
1002: !    Assignment Problems," Computing 38, 325-340, 1987 
1003: ! 
1004: !   by 
1005: ! 
1006: !   R. Jonker and A. Volgenant, University of Amsterdam. 
1007: ! 
1008: ! 
1009: ! INPUT PARAMETERS : 
1010: ! N = NUMBER OF ROWS AND COLUMNS 
1011: ! C = WEIGHT MATRIX 
1012: ! 
1013: ! OUTPUT PARAMETERS 
1014: ! X = COL ASSIGNED TO ROW 
1015: ! Y = ROW ASSIGNED TO COL 
1016: ! U = DUAL ROW VARIABLE 
1017: ! V = DUAL COLUMN VARIABLE 
1018: ! H = VALUE OF OPTIMAL SOLUTION 
1019: ! 
1020: ! INITIALIZATION 
1021:  
1022: !     Next line added by tomaso@nada.kth.se, to enable detection 
1023: !     of solutions being equivalent to the initial guess 
1024:  
1025: ! 
1026: !  If Y(:) is initialised to zero then we see segmentation faults if 
1027: !  a Y element is unset, etc. 
1028: ! 
1029:  
1030:       Y(1:N) = 0 
1031:       X(1:N) = 0 
1032:       TODO(1:N)=0 
1033:       h = -1 
1034:       DO 10 J=1,N 
1035:          V(J)=BIGINT 
1036:    10 CONTINUE 
1037:       DO 20 I=1,N 
1038:          X(I)=0 
1039:          DO 15 T=FIRST(I),FIRST(I+1)-1 
1040:             J=KK(T) 
1041:             IF (CC(T).LT.V(J)) THEN 
1042:               V(J)=CC(T) 
1043:               Y(J)=I 
1044:             END IF 
1045:    15    CONTINUE 
1046:    20 CONTINUE 
1047:       DO 30 J=1,N 
1048:          J0=N-J+1 
1049:          I=Y(J0) 
1050:          IF (I.EQ.0) THEN 
1051: !           PRINT '(A,I6,A)','minperm> WARNING B - matching failed' 
1052:             RETURN 
1053:          ENDIF 
1054:          IF (X(I).NE.0) THEN 
1055:            X(I)=-ABS(X(I)) 
1056:            Y(J0)=0 
1057:          ELSE 
1058:            X(I)=J0 
1059:          END IF 
1060:    30 CONTINUE 
1061:       L=0 
1062:       DO 40 I=1,N 
1063:          IF (X(I).EQ.0) THEN 
1064:            L=L+1 
1065:            FREE(L)=I 
1066:            GOTO 40 
1067:          END IF 
1068:          IF (X(I).LT.0) THEN 
1069:            X(I)=-X(I) 
1070:          ELSE 
1071:            J1=X(I) 
1072:            MIN=BIGINT 
1073:            DO 31 T=FIRST(I),FIRST(I+1)-1 
1074:               J=KK(T) 
1075:               IF (J.EQ.J1) GOTO 31 
1076:               IF (CC(T)-V(J).LT.MIN) MIN=CC(T)-V(J) 
1077:    31      CONTINUE 
1078:            V(J1)=V(J1)-MIN 
1079:          END IF 
1080:    40 CONTINUE 
1081: ! IMPROVE THE INITIAL SOLUTION 
1082:       CNT=0 
1083:       IF (L.EQ.0) RETURN 
1084:    41 L0=L 
1085:       K=1 
1086:       L=0 
1087:    50 I=FREE(K) 
1088:       K=K+1 
1089:       V0=BIGINT 
1090:       VJ=BIGINT 
1091:       DO 42 T=FIRST(I),FIRST(I+1)-1 
1092:          J=KK(T) 
1093:          H=CC(T)-V(J) 
1094:          IF (H.LT.VJ) THEN 
1095:            IF (H.GE.V0) THEN 
1096:              VJ=H 
1097:              J1=J 
1098:            ELSE 
1099:              VJ=V0 
1100:              V0=H 
1101:              J1=J0 
1102:              J0=J 
1103:            END IF 
1104:          END IF 
1105:    42 CONTINUE 
1106:       I0=Y(J0) 
1107:       IF (V0.LT.VJ) THEN 
1108:         V(J0)=V(J0)-VJ+V0 
1109:       ELSE 
1110:          if (j1 .lt. 0) then 
1111:             write(*,*) "error j1 is being used uninitialized" 
1112:             stop 
1113:          endif 
1114:         IF (I0.EQ.0) GOTO 43 
1115:         J0=J1 
1116:         I0=Y(J1) 
1117:       END IF 
1118:       IF (I0.EQ.0) GOTO 43 
1119:       IF (V0.LT.VJ) THEN 
1120:         K=K-1 
1121:         FREE(K)=I0 
1122:       ELSE 
1123:         L=L+1 
1124:         FREE(L)=I0 
1125:       END IF 
1126:    43 X(I)=J0 
1127:       Y(J0)=I 
1128:       IF (K.LE.L0) GOTO 50 
1129:       CNT=CNT+1 
1130:       IF ((L.GT.0).AND.(CNT.LT.2)) GOTO 41 
1131: ! AUGMENTATION PART 
1132:       L0=L 
1133:       DO 90 L=1,L0 
1134:          DO 51 J=1,N 
1135:             OK(J)=.FALSE. 
1136:             D(J)=BIGINT 
1137:    51    CONTINUE 
1138:          MIN=BIGINT 
1139:          I0=FREE(L) 
1140:          TD=N 
1141:          DO 52 T=FIRST(I0),FIRST(I0+1)-1 
1142:             J=KK(T) 
1143:             DJ=CC(T)-V(J) 
1144:             D(J)=DJ 
1145:             LAB(J)=I0 
1146:             IF (DJ.LE.MIN) THEN 
1147:               IF (DJ.LT.MIN) THEN 
1148:                 MIN=DJ 
1149:                 K=1 
1150:                 TODO(1)=J 
1151:               ELSE 
1152:                 K=K+1 
1153:                 TODO(K)=J 
1154:               END IF 
1155:             END IF 
1156:    52    CONTINUE 
1157:          DO 53 H=1,K 
1158:             J=TODO(H) 
1159:             IF (J.EQ.0) THEN 
1160: !              PRINT '(A,I6,A)','minperm> WARNING C - matching failed' 
1161:                RETURN 
1162:             ENDIF 
1163:             IF (Y(J).EQ.0) GOTO 80 
1164:             OK(J)=.TRUE. 
1165:    53    CONTINUE 
1166: ! REPEAT UNTIL A FREE ROW HAS BEEN FOUND 
1167:    60    IF (K.EQ.0) THEN 
1168: !           PRINT '(A,I6,A)','minperm> WARNING D - matching failed' 
1169:             RETURN 
1170:          ENDIF 
1171:          J0=TODO(K) 
1172:          K=K-1 
1173:          I=Y(J0) 
1174:          TODO(TD)=J0 
1175:          TD=TD-1 
1176:          T0=FIRST(I) 
1177:          T=T0-1 
1178:    61    T=T+1 
1179:          IF (KK(T).NE.J0) GOTO 61 
1180:          H=CC(T)-V(J0)-MIN 
1181:          DO 62 T=T0,FIRST(I+1)-1 
1182:             J=KK(T) 
1183:             IF (.NOT. OK(J)) THEN 
1184:               VJ=CC(T)-H-V(J) 
1185:               IF (VJ.LT.D(J)) THEN 
1186:                 D(J)=VJ 
1187:                 LAB(J)=I 
1188:                 IF (VJ.EQ.MIN) THEN 
1189:                   IF (Y(J).EQ.0) GOTO 70 
1190:                   K=K+1 
1191:                   TODO(K)=J 
1192:                   OK(J)=.TRUE. 
1193:                 END IF 
1194:               END IF 
1195:             END IF 
1196:    62    CONTINUE 
1197:          IF (K.NE.0) GOTO 60 
1198:          MIN=BIGINT-1 
1199:          DO 63 J=1,N 
1200:             IF (D(J).LE.MIN) THEN 
1201:               IF (.NOT. OK(J)) THEN 
1202:                 IF (D(J).LT.MIN) THEN 
1203:                   MIN=D(J) 
1204:                   K=1 
1205:                   TODO(1)=J 
1206:                 ELSE 
1207:                   K=K+1 
1208:                   TODO(K)=J 
1209:                 END IF 
1210:               END IF 
1211:             END IF 
1212:    63    CONTINUE 
1213:          DO 64 J0=1,K 
1214:             J=TODO(J0) 
1215:             IF (Y(J).EQ.0) GOTO 70 
1216:             OK(J)=.TRUE. 
1217:    64    CONTINUE 
1218:          GOTO 60 
1219:    70    IF (MIN.EQ.0) GOTO 80 
1220:          DO 71 K=TD+1,N 
1221:             J0=TODO(K) 
1222:             V(J0)=V(J0)+D(J0)-MIN 
1223:    71    CONTINUE 
1224:    80    I=LAB(J) 
1225:          Y(J)=I 
1226:          K=J 
1227:          J=X(I) 
1228:          X(I)=K 
1229:          IF (I0.NE.I) GOTO 80 
1230:    90 CONTINUE 
1231:       H=0 
1232:       DO 100 I=1,N 
1233:          J=X(I) 
1234:          T=FIRST(I)-1 
1235:   101    T=T+1 
1236:          IF (T.GT.SZ) THEN 
1237:             PRINT '(A,I6,A)','alignutils> WARNING D - atom ',I,' not matched - maximum number of neighbours too small?' 
1238:             RETURN 
1239:          ENDIF 
1240:          IF (KK(T).NE.J) GOTO 101 
1241:          DJ=CC(T) 
1242:          U(I)=DJ-V(J) 
1243:          H=H+DJ 
1244:   100 CONTINUE 
1245:  
1246: END SUBROUTINE JOVOSAP 
1247:  
1248: SUBROUTINE ADDCOORDS(COORDS, NCOORDS, NBULKT, DIST, RMAT, DISP) 
1249:  
1250: IMPLICIT NONE 
1251: INTEGER, INTENT(IN) :: NCOORDS 
1252: DOUBLE PRECISION, INTENT(IN) :: COORDS(3*NCOORDS), DIST, RMAT(3,3), DISP(3) 
1253: LOGICAL, INTENT(IN) :: NBULKT 
1254:  
1255: INTEGER J, STARTSHIFT 
1256: DOUBLE PRECISION DIFF 
1257:  
1258: BULKT = NBULKT 
1259:  
1260: NATOMS = NCOORDS 
1261: CALL REALLOCATEARRAYS() 
1262:  
1263: IF (NSTORED.EQ.0) THEN 
1264:     STARTSHIFT = 1 
1265: ENDIF 
1266:  
1267: DO STARTSHIFT=1,NSTORED 
1268:     IF (ABS(DIST-BESTDISTS(STARTSHIFT)).LT.DTOL) THEN 
1269:         ! Testing whether structure identical to one already stored 
1270:         DIFF = 0.D0 
1271:         DO J=1,NCOORDS 
1272:             DIFF = DIFF + PAIRDIST(BESTCOORDS(3*J-2:3*J,STARTSHIFT),COORDS(3*J-2:3*J)) 
1273:         ENDDO 
1274:         IF (SQRT(DIFF).LT.DTOL) THEN 
1275:             IF (DEBUG) WRITE(MYUNIT, "(A,I3)") & 
1276:      & "alignutils> structure being added identical to structure=", STARTSHIFT 
1277:             RETURN 
1278:         END IF 
1279:     END IF 
1280:     IF (DIST.LT.BESTDISTS(STARTSHIFT)) EXIT 
1281: END DO 
1282:  
1283: IF (STARTSHIFT.LE.(NSTORED+1).AND.(STARTSHIFT.LE.NSAVE)) THEN 
1284:     IF (DEBUG) WRITE(MYUNIT, "(A,I3,A,I3)") & 
1285:      & "alignutils> saving coords, added at=",STARTSHIFT, " total stored=", NSTORED 
1286:     CALL SHIFTCOORDS(STARTSHIFT) 
1287:     BESTDISTS(STARTSHIFT) = DIST 
1288:     BESTCOORDS(:,STARTSHIFT) = COORDS(:) 
1289:     BESTRMATS(:,:,STARTSHIFT) = RMAT(:,:) 
1290:     BESTDISPS(:,STARTSHIFT) = DISP(:) 
1291: ENDIF 
1292:  
1293: END SUBROUTINE ADDCOORDS 
1294:  
1295: SUBROUTINE PRINTDISTANCES() 
1296:  
1297: IMPLICIT NONE 
1298: INTEGER J 
1299:  
1300: WRITE(MYUNIT, "(A,I3,A)") "alignutils> found", NSTORED, " candidate alignments with distances:" 
1301: DO J=1,NSTORED 
1302:     WRITE(MYUNIT, "(G20.10)") BESTDISTS(J) 
1303: END DO 
1304:  
1305: END SUBROUTINE PRINTDISTANCES 
1306:  
1307: SUBROUTINE SHIFTCOORDS(STARTSHIFT) 
1308:  
1309: IMPLICIT NONE 
1310: INTEGER, INTENT(IN) :: STARTSHIFT 
1311:  
1312: INTEGER J,MAXJ 
1313:  
1314: MAXJ = MIN(NSTORED,NSAVE-1) 
1315: DO J=MAXJ,STARTSHIFT,-1 
1316:     BESTDISTS(J+1) = BESTDISTS(J) 
1317:     BESTCOORDS(:,J+1) = BESTCOORDS(:,J) 
1318:     BESTRMATS(:,:,J+1) = BESTRMATS(:,:,J) 
1319:     BESTDISPS(:,J+1) = BESTDISPS(:,J) 
1320: END DO 
1321:  
1322: NSTORED = MIN(NSTORED+1,NSAVE) 
1323:  
1324: END SUBROUTINE SHIFTCOORDS 
1325:  
1326: END MODULE 


r33355/bnbalign.f90 2017-09-28 12:30:14.891915931 +0100 r33354/bnbalign.f90 2017-09-28 12:30:16.679939469 +0100
  1: ! Subroutines:  1: !INCLUDE "commons.f90"
  2: ! 
  3: !    BNB_ALIGN(COORDSB,COORDSA,NATOMS,DEBUGT,NBOXLX,NBOXLY,NBOXLZ,NBULKT,DISTANCE,DIST2,RMATBEST,NSTEPS) 
  4:  
  5: !    RUN(NITER, FORCE, IPRINT, BESTUPPER) 
  6:  
  7: !    ADDNODE(VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE,LOWERBOUND,UPPERBOUND) 
  8:  
  9: !    BRANCH(VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE) 
 10:  
 11: !    CALCBOUNDS(LOWERBOUND,UPPERBOUND,VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE) 
 12:  
 13: !    FINDPERMVAL(PERM, NATOMS, MATVALS, DINVIDX, MAXNEI, NPERMGROUP, BEST) 
 14:  
 15: !    INVPAIRDISTIDX(DUMMYIDX, DINVIDX, NATOMS, MAXNEI, NPERMGROUP) 
 16:  
 17: !    PERMNEARESTNEIGHBOURDISTS(NDISTS,NIDX,NATOMS,MAXNEI,NEARI,NEARD,NPERMGROUP) 
 18:  
 19: !    NEARESTNEIGHBOURDISTS(CC, KK, N, MAXNEI, IDX, DISTS) 
 20:  
 21: !    QUEUEPUT(LOWERBOUND, UPPERBOUND, VECTOR, WIDTH, NITER, IDNUM) 
 22:  
 23: !    INITIALISE(COORDSB,COORDSA,NATOMS,NBOXLX,NBOXLY,NBOXLZ,NBULKT) 
 24:  
 25: !    SETNATOMS(NEWNATOMS) 
 26:  
 27: !    SETPERM(NEWNATOMS, NEWPERMGROUP, NEWNPERMSIZE) 
 28:  
 29: !    TRANSFORM(NEWCOORDSA, NATOMS, VECTOR, IDNUM) 
 30:  
 31: !    ANGLEAXIS2MAT(VECTOR,RMAT) 
 32:  
 33: !    MAT2ANGLEAXIS(VECTOR, RMAT) 
 34:  
 35: !    REALLOCATEARRAYS(NATOMS, NUMSTRUCTS, BULKT) 
 36:  
 37: !    SETCLUSTER(INVERT) 
 38:  
 39: !    SETBULK(INVERT) 
 40:  
 41: ! Functions: 
 42: !    BOUNDROTDISTANCE(D2,COSW,SINW,RA,RB) 
 43:   2: 
 44: !    QUEUELEN()  3: MODULE GOPERMDIST
 45:   4: 
 46: !***********************************************************************  5: ! SAVECOORDSA(3*NATOMS,NSTRUCTS) stores the centred candidate structures
   6: ! SAVECOORDSB(3*NATOMS) stores the centred target structure
 47:   7: 
 48: !INCLUDE "commons.f90"  8: ! PERMCOORDSB(3,NATOMS,NPERMGROUP) stores the structures for the k-d tree
 49: !INCLUDE "alignutils.f90" 
 50:   9: 
 51: MODULE GOPERMDIST 
 52:  10: 
 53: ! USE COMMONS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM, MYUNIT!, & 11: USE COMMONS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM, MYUNIT, &
 54: ! & NSETS, SETS, OHCELLT, PERMINVOPT, PERMDIST, PERMOPT, BOXLX, BOXLY, BOXLZ 12:  & NSETS, SETS, OHCELLT, PERMINVOPT, PERMDIST, PERMOPT, BOXLX, BOXLY, BOXLZ
 55: USE ALIGNUTILS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM, MYUNIT, & 13: USE PREC, ONLY: INT64
 56:  & NSETS, SETS, DEBUG, OHCELLT, PERMINVOPT, NOINVERSION, BOXLX, BOXLY, BOXLZ, & 
 57:  & TWOD, SAVECOORDS, NSTORED 
 58: USE PRIORITYQUEUE, ONLY: QUEUE 14: USE PRIORITYQUEUE, ONLY: QUEUE
 59: USE PREC, ONLY: INT64, REAL64 
 60:  15: 
 61: IMPLICIT NONE 16: IMPLICIT NONE
 62:  17: 
 63: INTEGER, SAVE :: NATOMS, NCALC, NLAP, NQUENCH, NBAD 18: INTEGER, SAVE :: NATOMS, NCALC, NLAP, NQUENCH, NBAD
 64: INTEGER, SAVE :: PMAXNEI = 60 ! Number of nearest neighbours to store 19: INTEGER, SAVE :: PMAXNEI = 60 ! Number of nearest neighbours to store
 65: INTEGER, SAVE :: PRINTRATE = 1 
 66: DOUBLE PRECISION, PARAMETER :: PSCALE = 1.D6 ! Scale for linear assignment problem 20: DOUBLE PRECISION, PARAMETER :: PSCALE = 1.D6 ! Scale for linear assignment problem
 67: DOUBLE PRECISION, PARAMETER :: PI = 3.141592653589793D0 21: DOUBLE PRECISION, PARAMETER :: PI = 3.141592653589793D0
 68: ! Absolute Tolerance, Relative Tolerance, Relative Tolerance for MINPERMDIST quench 22: ! Absolute Tolerance, Relative Tolerance, Relative Tolerance for MINPERMDIST quench
 69: DOUBLE PRECISION, SAVE :: ATOL=1D-8, RTOL=1D-1, MPRTOL=1.D-1 23: DOUBLE PRECISION, SAVE :: ATOL=1D-8, RTOL=1D-1, MPRTOL=1.D-1
  24: LOGICAL, SAVE :: DEBUG = .TRUE.
  25: 
 70:  26: 
 71: DOUBLE PRECISION, SAVE :: LVECS(3,0:8), FVECS(4,6), TWODVECS(3,0:4) 27: DOUBLE PRECISION, SAVE :: LVECS(3,0:8), FVECS(4,6)
 72:  28: 
 73: DOUBLE PRECISION, SAVE :: CMAX,CMAY,CMAZ,CMBX,CMBY,CMBZ 29: DOUBLE PRECISION, SAVE :: CMAX,CMAY,CMAZ,CMBX,CMBY,CMBZ
 74: DOUBLE PRECISION, SAVE :: DUMMYRMAT(3,3), TRMAT(3,3), DUMMYDISP(3) 30: DOUBLE PRECISION, SAVE :: DUMMYRMAT(3,3), TRMAT(3,3)
 75: LOGICAL, SAVE :: FORCEASSIGNMENT=.FALSE. 31: LOGICAL, SAVE :: PERMINVOPTSAVE, NOINVERSIONSAVE
 76:  32: 
 77: ! Module saves periodic conditions variables 33: ! Module saves periodic conditions variables
 78: LOGICAL, SAVE :: BULKT 34: LOGICAL, SAVE :: BULKT
 79: LOGICAL, SAVE :: OHCELLTSAVE 35: LOGICAL, SAVE :: OHCELLTSAVE
 80: DOUBLE PRECISION, SAVE :: BOXVEC(3), DISPBEST(3) 36: DOUBLE PRECISION, SAVE :: BOXVEC(3)
 81:  37: 
 82: ! Arrays to store target and candidate structures and best found structures 38: ! Arrays to store target and candidate structures and best found structures
 83: DOUBLE PRECISION, SAVE, ALLOCATABLE  :: SAVECOORDSA(:,:),PERMCOORDSB(:,:,:), & 39: DOUBLE PRECISION, SAVE, ALLOCATABLE  :: SAVECOORDSA(:,:),PERMCOORDSB(:,:,:), &
 84:  & SAVECOORDSB(:), BESTCOORDSA(:,:), BESTRMAT(:,:,:), BESTDISP(:,:) 40:  & SAVECOORDSB(:), BESTCOORDSA(:,:), BESTRMAT(:,:,:)
 85: DOUBLE PRECISION, SAVE, ALLOCATABLE  :: SAVERA(:,:), SAVERB(:) 41: DOUBLE PRECISION, SAVE, ALLOCATABLE  :: SAVERA(:,:), SAVERB(:)
 86: INTEGER, SAVE, ALLOCATABLE :: BESTITERS(:), BESTPERMS(:,:) 42: INTEGER, SAVE, ALLOCATABLE :: BESTITERS(:)
 87: INTEGER, SAVE :: BESTID, BESTITER 43: INTEGER, SAVE :: BESTID, BESTITER
 88:  44: 
 89:  45: 
 90: ! Used when calculating Boundsin CALCBOUNDS 46: ! Used when calculating Boundsin CALCBOUNDS
 91: DOUBLE PRECISION :: BRANCHVECS(3,8) 47: DOUBLE PRECISION :: BRANCHVECS(3,8)
 92: DOUBLE PRECISION, SAVE, ALLOCATABLE  :: DUMMYCOORDSA(:,:), PDUMMYND(:) 48: DOUBLE PRECISION, SAVE, ALLOCATABLE  :: DUMMYCOORDSA(:,:), PDUMMYND(:)
 93: ! Arrays of distances and nearest neighbour distances 49: ! Arrays of distances and nearest neighbour distances
 94:  
 95: DOUBLE PRECISION, SAVE, ALLOCATABLE :: DUMMYDISTS(:,:), DUMMYNEARDISTS(:) 50: DOUBLE PRECISION, SAVE, ALLOCATABLE :: DUMMYDISTS(:,:), DUMMYNEARDISTS(:)
 96:  
 97: DOUBLE PRECISION, SAVE, ALLOCATABLE :: DUMMYDISPS(:,:,:) 51: DOUBLE PRECISION, SAVE, ALLOCATABLE :: DUMMYDISPS(:,:,:)
 98: ! Arrays of bounded distances and nearest neighbour distances 52: ! Arrays of bounded distances and nearest neighbour distances
 99: DOUBLE PRECISION, SAVE, ALLOCATABLE :: DUMMYLDISTS(:,:), DUMMYNEARLDISTS(:), & 53: DOUBLE PRECISION, SAVE, ALLOCATABLE :: DUMMYLDISTS(:,:), DUMMYNEARLDISTS(:), &
100:  & DUMMYLDISTS2(:,:), DUMMYDOTDISP(:,:,:) 54:  & DUMMYLDISTS2(:,:), DUMMYDOTDISP(:,:,:)
101:  55: 
102: INTEGER, SAVE, ALLOCATABLE :: DUMMYIDX(:,:), DINVIDX(:,:), DUMMYNEARIDX(:) 56: INTEGER, SAVE, ALLOCATABLE :: DUMMYIDX(:,:), DINVIDX(:,:), DUMMYNEARIDX(:)
103: INTEGER, SAVE, ALLOCATABLE :: INVPERMGROUP(:) 57: INTEGER, SAVE, ALLOCATABLE :: INVPERMGROUP(:)
104:  58: 
105: ! Used when solving assignment problem 59: ! Used when solving assignment problem
106: DOUBLE PRECISION, SAVE, ALLOCATABLE :: PDUMMYA(:), PDUMMYB(:), DUMMYA(:), & 60: DOUBLE PRECISION, SAVE, ALLOCATABLE :: PDUMMYA(:), PDUMMYB(:), DUMMYA(:), &
107:     & DUMMYB(:), XBESTA(:), XBESTASAVE(:) 61:     & DUMMYB(:), XBESTA(:), XBESTASAVE(:)
  62: INTEGER, SAVE, ALLOCATABLE :: NEWPERM(:), LPERM(:)
108:  63: 
109: INTEGER, SAVE, ALLOCATABLE :: NEWPERM(:), LPERM(:), PERMBEST(:) 64: !TYPE(KDTREE2PTR), ALLOCATABLE :: KDTREES(:)
110:  
111: TYPE(QUEUE) :: Q 65: TYPE(QUEUE) :: Q
112:  66: 
113: DATA LVECS / & 67: DATA LVECS / &
114:  &  0.0D0,  0.0D0,  0.0D0, & 68:  & 0.0D0, 0.0D0, 0.0D0, &
115:  &  1.0D0,  1.0D0,  1.0D0, & 69:  & 1.0D0, 1.0D0, 1.0D0, &
116:  &  1.0D0,  1.0D0, -1.0D0, & 70:  & 1.0D0, 1.0D0, -1.0D0, &
117:  &  1.0D0, -1.0D0,  1.0D0, & 71:  & 1.0D0, -1.0D0, 1.0D0, &
118:  &  1.0D0, -1.0D0, -1.0D0, & 72:  & 1.0D0, -1.0D0, -1.0D0, &
119:  & -1.0D0,  1.0D0,  1.0D0, & 73:  & -1.0D0, 1.0D0, 1.0D0, &
120:  & -1.0D0,  1.0D0, -1.0D0, & 74:  & -1.0D0, 1.0D0, -1.0D0, &
121:  & -1.0D0, -1.0D0,  1.0D0, & 75:  & -1.0D0, -1.0D0, 1.0D0, &
122:  & -1.0D0, -1.0D0, -1.0D0 / 76:  & -1.0D0, -1.0D0, -1.0D0 /
123:  77: 
124: DATA FVECS / & 78: DATA FVECS / &
125:  &  1.0D0,  1.0D0,  1.0D0,  1.0D0, & 79:  &  1.0D0,  1.0D0,  1.0D0,  1.0D0, &
126:  &  1.0D0,  1.0D0, -1.0D0, -1.0D0, & 80:  &  1.0D0,  1.0D0, -1.0D0, -1.0D0, &
127:  &  1.0D0, -1.0D0,  1.0D0, -1.0D0, & 81:  &  1.0D0, -1.0D0,  1.0D0, -1.0D0, &
128:  & -1.0D0, -1.0D0, -1.0D0, -1.0D0, & 82:  & -1.0D0, -1.0D0, -1.0D0, -1.0D0, &
129:  & -1.0D0, -1.0D0,  1.0D0,  1.0D0, & 83:  & -1.0D0, -1.0D0,  1.0D0,  1.0D0, &
130:  & -1.0D0,  1.0D0, -1.0D0,  1.0D0 / 84:  & -1.0D0,  1.0D0, -1.0D0,  1.0D0 /
131:  85: 
132: DATA TWODVECS / & 86: ! Private so that module works with f2py and static linking to kdtree2.f90 and
133:  &  0.0D0,  0.0D0,  0.0D0, & 87: ! priorityqueue.f90
134:  &  1.0D0,  1.0D0,  0.0D0, & 88: PRIVATE :: Q!, KDTREES
135:  &  1.0D0, -1.0D0,  0.0D0, & 
136:  & -1.0D0,  1.0D0,  0.0D0, & 
137:  & -1.0D0, -1.0D0,  0.0D0 / 
138:  
139: ! Private so that module works with f2py and static linking to priorityqueue.f90 
140: PRIVATE :: Q 
141:  89: 
142: CONTAINS 90: CONTAINS
143:  91: 
144: SUBROUTINE BNB_ALIGN(COORDSB,COORDSA,NCOORDS,DEBUGT,NBOXLX,NBOXLY,NBOXLZ,NBULKT, & 92: SUBROUTINE BNB_ALIGN(COORDSB,COORDSA,LNATOMS,DEBUGT,NBOXLX,NBOXLY,NBOXLZ,NBULKT, &
145:     & DISTANCE,DIST2,RMATBEST,NSTEPS) 93:     & DISTANCE,DIST2,RMATBEST,NSTEPS)
146:  94: 
147: IMPLICIT NONE 95: IMPLICIT NONE
148:  96: 
149: LOGICAL, INTENT(IN) :: NBULKT, DEBUGT 97: LOGICAL, INTENT(IN) :: NBULKT, DEBUGT
150: INTEGER, INTENT(IN) :: NCOORDS, NSTEPS 98: INTEGER, INTENT(IN) :: LNATOMS, NSTEPS
151: DOUBLE PRECISION, INTENT(INOUT) :: COORDSB(3*NCOORDS), COORDSA(3*NCOORDS) 99: DOUBLE PRECISION, INTENT(INOUT) :: COORDSB(3*LNATOMS), COORDSA(3*LNATOMS)
152: DOUBLE PRECISION, INTENT(IN) :: NBOXLX, NBOXLY, NBOXLZ100: DOUBLE PRECISION, INTENT(IN) :: NBOXLX, NBOXLY, NBOXLZ
153: 101: 
154: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2, RMATBEST(3,3)102: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2, RMATBEST(3,3)
155: 103: 
156: DOUBLE PRECISION VECTOR(3), WIDTH, BESTUPPER, LOWERBOUND, UPPERBOUND104: DOUBLE PRECISION VECTOR(3), WIDTH, BESTUPPER, LOWERBOUND, UPPERBOUND
157: INTEGER IDNUM105: INTEGER IDNUM
158: 106: 
 107: 
159: ! Allocating and assigning to temporary arrays108: ! Allocating and assigning to temporary arrays
160: NATOMS = NCOORDS109: CALL SETNATOMS(LNATOMS)
161: !CALL SETNATOMS(NATOMS) 
162: CALL INITIALISE(COORDSB, COORDSA, NATOMS, NBOXLX, NBOXLY, NBOXLZ, NBULKT)110: CALL INITIALISE(COORDSB, COORDSA, NATOMS, NBOXLX, NBOXLY, NBOXLZ, NBULKT)
163: 111: 
164: ! Setting parameters112: ! Setting parameters
165: DEBUG = DEBUGT113: DEBUG = DEBUGT
166: NSTORED = 0 ! For saving coordinates 
167: BESTUPPER = HUGE(1.D0)114: BESTUPPER = HUGE(1.D0)
168: VECTOR(:) = 0.D0115: VECTOR(:) = 0.D0
169: IF(BULKT) THEN116: IF(BULKT) THEN
170:     WIDTH = MAX(NBOXLX, NBOXLY, NBOXLZ)117:     WIDTH = MAX(NBOXLX, NBOXLY, NBOXLZ)
171: ELSE118: ELSE
172:     WIDTH = 2.D0 * PI119:     WIDTH = 2.D0 * PI
173: END IF120: END IF
174: 121: 
175: ! Initialise BnB nodes122: ! Initialise BnB nodes
176: IDNUM = 1123: IDNUM = 1
181:     ! Adding all 48 octahedral symmetries128:     ! Adding all 48 octahedral symmetries
182:     DO IDNUM=2,48129:     DO IDNUM=2,48
183:         CALL ADDNODE(VECTOR,WIDTH,IDNUM,BESTUPPER,.TRUE.,LOWERBOUND,UPPERBOUND)130:         CALL ADDNODE(VECTOR,WIDTH,IDNUM,BESTUPPER,.TRUE.,LOWERBOUND,UPPERBOUND)
184:     END DO131:     END DO
185: ELSE IF(PERMINVOPT) THEN132: ELSE IF(PERMINVOPT) THEN
186:     ! Adding permutation inversion isomer133:     ! Adding permutation inversion isomer
187:     CALL ADDNODE(VECTOR,WIDTH,2,BESTUPPER,.TRUE.,LOWERBOUND,UPPERBOUND)134:     CALL ADDNODE(VECTOR,WIDTH,2,BESTUPPER,.TRUE.,LOWERBOUND,UPPERBOUND)
188: END IF135: END IF
189: 136: 
190: ! Perform BnB137: ! Perform BnB
191: CALL RUN(NSTEPS,FORCEASSIGNMENT,PRINTRATE,BESTUPPER)138: CALL RUN(NSTEPS,.FALSE.,1,BESTUPPER)
192: 139: 
193: ! Return results140: ! Return results
194: COORDSB(:) = SAVECOORDSB(:)141: COORDSB(:) = SAVECOORDSB(:)
195: COORDSA(:) = BESTCOORDSA(:,BESTID)142: COORDSA(:) = BESTCOORDSA(:,BESTID)
196: 143: 
197: DISTANCE = BESTUPPER144: DISTANCE = BESTUPPER
198: DIST2 = DISTANCE**2145: DIST2 = DISTANCE**2
199: 146: 
200: IF (NBULKT) THEN147: IF(.NOT.NBULKT) THEN
201:         DISPBEST = BESTDISP(:,BESTID) 
202: ELSE 
203:     RMATBEST = BESTRMAT(:,:,BESTID)148:     RMATBEST = BESTRMAT(:,:,BESTID)
204: ENDIF149: ENDIF
205: 150: 
206: BESTPERM = BESTPERMS(:,BESTID) 
207:  
208: END SUBROUTINE BNB_ALIGN151: END SUBROUTINE BNB_ALIGN
209: 152: 
210: SUBROUTINE RUN(NITER, FORCE, IPRINT, BESTUPPER)153: SUBROUTINE RUNGROUP(NITER, FORCE, IPRINT, BESTUPPER, NSTRUCTS, UPDATE)
 154: IMPLICIT NONE
 155: 
 156: INTEGER, INTENT(IN) :: NITER, IPRINT, NSTRUCTS, UPDATE
 157: LOGICAL, INTENT(IN) :: FORCE
 158: DOUBLE PRECISION, INTENT(INOUT) :: BESTUPPER(NSTRUCTS)
 159: 
 160: 
 161: DOUBLE PRECISION LOWERBOUND, UPPERBOUND, VECTOR(3), WIDTH
 162: INTEGER I,IDNUM,NODEITER,NSUCCESS
211: 163: 
212: USE ALIGNUTILS, ONLY : PRINTDISTANCES164: DO I=1,NITER
 165: 
 166:     CALL QUEUEGET(LOWERBOUND, UPPERBOUND, VECTOR, WIDTH, NODEITER, IDNUM)
 167: 
 168:     CALL BRANCH(VECTOR,WIDTH,IDNUM,BESTUPPER(IDNUM),FORCE)
 169: 
 170:     IF(DEBUG.AND.(IPRINT.GT.0).AND.(MOD(I,IPRINT).EQ.0)) THEN
 171:         WRITE(MYUNIT,'(A)') &
 172:          & "gopermdist> -----------------STATUS UPDATE----------------"
 173:         WRITE(MYUNIT,'(A,I16)') &
 174:          & "gopermdist> iteration  number           = ", I
 175: !        WRITE(MYUNIT,'(A,G20.6)') &
 176: !         & "gopermdist> lowest upper bound so far   = ", BESTUPPER
 177:         WRITE(MYUNIT,'(A,G20.6)') &
 178:          & "gopermdist> highest lower bound so far  = ", LOWERBOUND
 179:         WRITE(MYUNIT,'(A,I16)') &
 180:          & "gopermdist> total calculations so far   = ", NCALC
 181:         WRITE(MYUNIT,'(A,I16)') &
 182:          & "gopermdist> queue length                = ", QUEUELEN()
 183:         WRITE(MYUNIT,'(A)') &
 184:          & "gopermdist> ----------------------------------------------"
 185:     ENDIF
 186: 
 187: 
 188:     IF(QUEUELEN().LE.0) THEN
 189:         IF(DEBUG) WRITE(MYUNIT,'(A)') &
 190:              & "gopermdist> priority queue empty, stopping"
 191:     END IF
 192: 
 193: !    IF((QUEUELEN().LE.0).OR.((LOWERBOUND).GT.(BESTUPPER - RTOL*BESTUPPER - ATOL))) THEN
 194: !        IF(DEBUG) THEN
 195: !            WRITE(MYUNIT,'(A)') &
 196: !             & "gopermdist> -------------------SUCCESS--------------------"
 197: !!            WRITE(MYUNIT,'(A,G20.6)') &
 198: !!             & "gopermdist> converged on minimum RMSD   = ", BESTUPPER
 199: !            WRITE(MYUNIT,'(A,I16)') &
 200: !             & "gopermdist> total calculations          = ", NCALC
 201: !            WRITE(MYUNIT,'(A,I16)') &
 202: !             & "gopermdist> found best on iteration     = ", BESTITER
 203: !            WRITE(MYUNIT,'(A,I16)') &
 204: !             & "gopermdist> best structure              = ", BESTID
 205: !            WRITE(MYUNIT,'(A)') &
 206: !             & "gopermdist> -------------------SUCCESS--------------------"
 207: !        END IF
 208: !        EXIT
 209: !    END IF
 210: 
 211: END DO
 212: 
 213: END SUBROUTINE RUNGROUP
 214: 
 215: SUBROUTINE RUN(NITER, FORCE, IPRINT, BESTUPPER)
213: IMPLICIT NONE216: IMPLICIT NONE
214: 217: 
215: INTEGER, INTENT(IN) :: NITER, IPRINT218: INTEGER, INTENT(IN) :: NITER, IPRINT
216: LOGICAL, INTENT(IN) :: FORCE219: LOGICAL, INTENT(IN) :: FORCE
217: DOUBLE PRECISION, INTENT(INOUT) :: BESTUPPER220: DOUBLE PRECISION, INTENT(INOUT) :: BESTUPPER
218: 221: 
219: DOUBLE PRECISION LOWERBOUND, UPPERBOUND, VECTOR(3), WIDTH222: DOUBLE PRECISION LOWERBOUND, UPPERBOUND, VECTOR(3), WIDTH
220: INTEGER I,IDNUM,NODEITER223: INTEGER I,IDNUM,NODEITER
221: 224: 
222: DO I=1,NITER225: DO I=1,NITER
260:             WRITE(MYUNIT,'(A,I16)') &263:             WRITE(MYUNIT,'(A,I16)') &
261:              & "gopermdist> best structure              = ", BESTID264:              & "gopermdist> best structure              = ", BESTID
262:             WRITE(MYUNIT,'(A)') &265:             WRITE(MYUNIT,'(A)') &
263:              & "gopermdist> -------------------SUCCESS--------------------"266:              & "gopermdist> -------------------SUCCESS--------------------"
264:         END IF267:         END IF
265:         EXIT268:         EXIT
266:     END IF269:     END IF
267: 270: 
268: END DO271: END DO
269: 272: 
270: IF (DEBUG.AND.SAVECOORDS) CALL PRINTDISTANCES() 
271:  
272: END SUBROUTINE273: END SUBROUTINE
273: 274: 
274: SUBROUTINE ADDNODE(VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE,LOWERBOUND,UPPERBOUND)275: SUBROUTINE ADDNODE(VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE,LOWERBOUND,UPPERBOUND)
275: 276: 
276: USE ALIGNUTILS, ONLY : ITERATIVEALIGN 
277:  
278: IMPLICIT NONE277: IMPLICIT NONE
279: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3), WIDTH278: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3), WIDTH
280: DOUBLE PRECISION, INTENT(INOUT) :: BESTUPPER279: DOUBLE PRECISION, INTENT(INOUT) :: BESTUPPER
281: DOUBLE PRECISION, INTENT(OUT) :: LOWERBOUND, UPPERBOUND280: DOUBLE PRECISION, INTENT(OUT) :: LOWERBOUND, UPPERBOUND
282: INTEGER, INTENT(IN) :: IDNUM281: INTEGER, INTENT(IN) :: IDNUM
283: LOGICAL, INTENT(IN) :: FORCE282: LOGICAL, INTENT(IN) :: FORCE
284: 283: 
285: DOUBLE PRECISION :: DIST2284: DOUBLE PRECISION :: DIST2
286: 285: 
 286: LOGICAL :: PERMINVOPTSAVE, OHCELLTSAVE, PERMOPTSAVE
 287: 
287: CALL CALCBOUNDS(LOWERBOUND,UPPERBOUND,VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE)288: CALL CALCBOUNDS(LOWERBOUND,UPPERBOUND,VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE)
288: 289: 
289: ! If upperbound within tolerance of lowest upperbound then quench with290: ! If upperbound within tolerance of lowest upperbound then quench with
290: ! minpermdist291: ! minpermdist
291: IF ((UPPERBOUND).LE.(BESTUPPER + MPRTOL*BESTUPPER + ATOL)) THEN292: IF ((UPPERBOUND).LE.(BESTUPPER + MPRTOL*BESTUPPER + ATOL)) THEN
 293:     PERMINVOPTSAVE = PERMINVOPT; OHCELLTSAVE = OHCELLT; PERMOPTSAVE = PERMOPT
 294:     OHCELLT = .FALSE.; PERMINVOPT = .FALSE.
 295:     ! sn402: the following line shouldn't be necessary any more: PERMOPT should be set at align_decide
 296: !    PERMOPT = .NOT. BULKT  ! PERMOPT needs to be FALSE for periodic alignments but true for cluster alignments
292: 297: 
293:     CALL ITERATIVEALIGN(SAVECOORDSB,DUMMYA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,BULKT, &298:     CALL MINPERMDIST(SAVECOORDSB,DUMMYA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,BULKT, &
294:     & DIST2,UPPERBOUND,DUMMYRMAT,DUMMYDISP,PERMBEST)299:  & .FALSE.,UPPERBOUND,DIST2,.FALSE.,DUMMYRMAT)
295: 300: 
296:     ! Resetting keywords301:     ! Resetting keywords
 302:     PERMINVOPT = PERMINVOPTSAVE; OHCELLT = OHCELLTSAVE; PERMOPT = PERMOPTSAVE
297:     NQUENCH = NQUENCH + 1303:     NQUENCH = NQUENCH + 1
298: 304: 
299:     IF(DEBUG) WRITE(MYUNIT, "(A,G20.5)") &305:     IF(DEBUG) WRITE(MYUNIT, "(A,G20.5)") &
300:  & "gopermdist> post quench new lowest RMSD = ", UPPERBOUND306:  & "gopermdist> post quench new lowest RMSD = ", UPPERBOUND
301: END IF307: END IF
302: 308: 
303: IF (UPPERBOUND.LT.BESTUPPER) THEN309: IF (UPPERBOUND.LT.BESTUPPER) THEN
 310: 
304:     BESTUPPER = UPPERBOUND311:     BESTUPPER = UPPERBOUND
305: 312: 
306:     IF(DEBUG) WRITE(MYUNIT, "(A,G20.5)") &313:     IF(DEBUG) WRITE(MYUNIT, "(A,G20.5)") &
307:  & "gopermdist> NEW lowest upper bound RMSD = ", UPPERBOUND314:  & "gopermdist> NEW lowest upper bound RMSD = ", UPPERBOUND
308: 315: 
309:     IF (.NOT.BULKT) THEN316: !    ! Don't need to test for inversion isomers
310:         BESTDISP(:,IDNUM) = DUMMYDISP317: !    PERMINVOPTSAVE = PERMINVOPT; OHCELLTSAVE = OHCELLT
311:     ELSE318: !    OHCELLT = .FALSE.; PERMINVOPT = .FALSE.
312:         BESTRMAT(:,:,IDNUM) = MATMUL(TRMAT,DUMMYRMAT)319: !
313:     END IF320: !    CALL MINPERMDIST(SAVECOORDSB,DUMMYA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,BULKT, &
 321: ! & .FALSE.,BESTUPPER,DIST2,.FALSE.,DUMMYRMAT)
 322: !
 323: !    ! Resetting keywords
 324: !    PERMINVOPT = PERMINVOPTSAVE; OHCELLT = OHCELLTSAVE
 325: !    NQUENCH = NQUENCH + 1
314: 326: 
 327:     IF (.NOT.BULKT) BESTRMAT(:,:,IDNUM) = MATMUL(TRMAT,DUMMYRMAT)
315:     BESTCOORDSA(:,IDNUM) = DUMMYA328:     BESTCOORDSA(:,IDNUM) = DUMMYA
316:     BESTPERMS(:,IDNUM) = PERMBEST 
317:     BESTID = IDNUM329:     BESTID = IDNUM
318:     BESTITER = NCALC330:     BESTITER = NCALC
319:     CALL QUEUEPUT(LOWERBOUND,UPPERBOUND,VECTOR,WIDTH,NCALC,IDNUM)331:     CALL QUEUEPUT(LOWERBOUND,UPPERBOUND,VECTOR,WIDTH,NCALC,IDNUM)
 332: 
320: ELSE IF( (LOWERBOUND ).LT.(BESTUPPER - RTOL*BESTUPPER - ATOL) ) THEN333: ELSE IF( (LOWERBOUND ).LT.(BESTUPPER - RTOL*BESTUPPER - ATOL) ) THEN
321:     CALL QUEUEPUT(LOWERBOUND,UPPERBOUND,VECTOR,WIDTH,NCALC,IDNUM)334:     CALL QUEUEPUT(LOWERBOUND,UPPERBOUND,VECTOR,WIDTH,NCALC,IDNUM)
322: END IF335: END IF
323: 336: 
324: END SUBROUTINE ADDNODE 
325: 337: 
326: 338: 
327: SUBROUTINE BRANCH(VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE)339: END SUBROUTINE ADDNODE
328: 340: 
329: USE ALIGNUTILS, ONLY : TWOD341: SUBROUTINE BRANCH(VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE)
330: 342: 
331: IMPLICIT NONE343: IMPLICIT NONE
332: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3), WIDTH344: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3), WIDTH
333: DOUBLE PRECISION, INTENT(INOUT) :: BESTUPPER345: DOUBLE PRECISION, INTENT(INOUT) :: BESTUPPER
334: INTEGER, INTENT(IN) :: IDNUM346: INTEGER, INTENT(IN) :: IDNUM
335: LOGICAL, INTENT(IN) :: FORCE347: LOGICAL, INTENT(IN) :: FORCE
336: 348: 
337: DOUBLE PRECISION :: LOWERBOUND, UPPERBOUND, NEWVECT(3),MINR349: DOUBLE PRECISION :: LOWERBOUND, UPPERBOUND, NEWVECT(3),MINR
338: 350: 
339: INTEGER I351: INTEGER I
340: 352: 
341: IF (BULKT.AND.TWOD) THEN353: DO I=1,8
342:     ! If 2D then only need to test 4 search cubes354:     NEWVECT(:) = VECTOR + LVECS(:,I)*WIDTH*0.25D0
343:     DO I=1,4355:     ! Check if rotation is within sphere
344:         NEWVECT(:) = VECTOR + TWODVECS(:,I)*WIDTH*0.25D0356:     IF(BULKT.OR.((SUM(NEWVECT**2)-0.75D0*WIDTH**2).LE.(PI**2))) CALL ADDNODE( &
345:         ! Check if displacement is within lattice cell357: & NEWVECT,WIDTH*0.5D0,IDNUM,BESTUPPER,FORCE,LOWERBOUND,UPPERBOUND)
346:         IF( ((BOXLX/2-ABS(NEWVECT(1))+WIDTH*0.25D0).GT.0.D0).AND. &358: END DO
347:           & ((BOXLY/2-ABS(NEWVECT(2))+WIDTH*0.25D0).GT.0.D0) ) CALL ADDNODE( & 
348:           & NEWVECT,WIDTH*0.5D0,IDNUM,BESTUPPER,FORCE,LOWERBOUND,UPPERBOUND) 
349:     END DO 
350: ELSE 
351:     DO I=1,8 
352:         NEWVECT(:) = VECTOR + LVECS(:,I)*WIDTH*0.25D0 
353:         IF(BULKT) THEN 
354:             ! Check if displacement is within lattice cell 
355:             IF( ((BOXLX/2-ABS(NEWVECT(1))+WIDTH*0.25D0).GT.0.D0).AND. & 
356:               & ((BOXLY/2-ABS(NEWVECT(2))+WIDTH*0.25D0).GT.0.D0).AND. & 
357:               & ((BOXLZ/2-ABS(NEWVECT(2))+WIDTH*0.25D0).GT.0.D0) ) CALL ADDNODE( & 
358:               & NEWVECT,WIDTH*0.5D0,IDNUM,BESTUPPER,FORCE,LOWERBOUND,UPPERBOUND) 
359:         ! Check if rotation is within sphere 
360:         ELSE IF ((SUM(NEWVECT**2)-0.75D0*WIDTH**2).LE.(PI**2)) THEN 
361:             CALL ADDNODE(NEWVECT,WIDTH*0.5D0,IDNUM,BESTUPPER,FORCE,LOWERBOUND,UPPERBOUND) 
362:         END IF 
363:     END DO 
364: END IF 
365: 359: 
366: END SUBROUTINE BRANCH360: END SUBROUTINE BRANCH
367: 361: 
368: SUBROUTINE CALCBOUNDS(LOWERBOUND,UPPERBOUND,VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE)362: SUBROUTINE CALCBOUNDS(LOWERBOUND,UPPERBOUND,VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE)
369: 363: 
370: USE ALIGNUTILS, ONLY : PERMPAIRDISTS, FINDBESTPERM364: USE COMMONS, ONLY: NATOMS
371: 365: 
372: IMPLICIT NONE366: IMPLICIT NONE
373: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3), WIDTH, BESTUPPER367: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3), WIDTH, BESTUPPER
374: INTEGER, INTENT(IN) :: IDNUM368: INTEGER, INTENT(IN) :: IDNUM
375: LOGICAL, INTENT(IN) :: FORCE369: LOGICAL, INTENT(IN) :: FORCE
376: 370: 
377: DOUBLE PRECISION, INTENT(OUT) :: LOWERBOUND, UPPERBOUND371: DOUBLE PRECISION, INTENT(OUT) :: LOWERBOUND, UPPERBOUND
378: 372: 
379: DOUBLE PRECISION W,SINW,COSW,RA,RB,ESTLOWER,ESTUPPER,D,V,COSP373: DOUBLE PRECISION W,SINW,COSW,RA,RB,ESTLOWER,ESTUPPER,D,V,COSP
380: INTEGER I,J,J1,M,K,K1,IND,NDUMMY,NPERM,INFO,IA,IB374: INTEGER I,J,J1,M,K,K1,IND,NDUMMY,NPERM,INFO,IA,IB
381: LOGICAL RECALC375: LOGICAL RECALC
382: 376: 
383: !DOUBLE PRECISION PERMDIST377: DOUBLE PRECISION PERMDIST
384: 378: 
385: IF(BULKT) THEN379: IF(BULKT) THEN
386:     W = SQRT(3.D0) * WIDTH * 0.5D0380:     W = SQRT(3.D0) * WIDTH * 0.5D0
387: ELSE381: ELSE
388:     V = SQRT(SUM(VECTOR**2))382:     V = SQRT(SUM(VECTOR**2))
389:     COSP = V/SQRT(V**2 + 0.75*WIDTH**2)383:     COSP = V/SQRT(V**2 + 0.75*WIDTH**2)
390:     !COSP = (V-WIDTH*0.5D0)/SQRT(V**2 - V*WIDTH + 0.5*WIDTH**2)384:     !COSP = (V-WIDTH*0.5D0)/SQRT(V**2 - V*WIDTH + 0.5*WIDTH**2)
391:     COSW = MIN(COS(WIDTH*0.5D0), (COS(V)**2 + COSP*SIN(V)**2) * COS(WIDTH*0.5D0) - &385:     COSW = MIN(COS(WIDTH*0.5D0), (COS(V)**2 + COSP*SIN(V)**2) * COS(WIDTH*0.5D0) - &
392:      & (1-COSP)*ABS(SIN(V)*COS(V)*SIN(WIDTH*0.5D0)) )386:      & (1-COSP)*ABS(SIN(V)*COS(V)*SIN(WIDTH*0.5D0)) )
393: !    COSW = COS(W)387: !    COSW = COS(W)
400:     IF(.NOT.BULKT) WRITE(MYUNIT, "(A,3F16.5)") &394:     IF(.NOT.BULKT) WRITE(MYUNIT, "(A,3F16.5)") &
401:  & "gopermdist> testing angle-axis vector   = ", VECTOR395:  & "gopermdist> testing angle-axis vector   = ", VECTOR
402:     WRITE(MYUNIT, "(A,G20.5,A,I4)") &396:     WRITE(MYUNIT, "(A,G20.5,A,I4)") &
403:  & "gopermdist> with width                  = ", WIDTH, &397:  & "gopermdist> with width                  = ", WIDTH, &
404:  & "     on IDNUM    =", IDNUM398:  & "     on IDNUM    =", IDNUM
405: END IF399: END IF
406: 400: 
407: CALL TRANSFORM(DUMMYA, NATOMS, VECTOR, IDNUM)401: CALL TRANSFORM(DUMMYA, NATOMS, VECTOR, IDNUM)
408: 402: 
409: ! Find distance matrix403: ! Find distance matrix
410:  
411: CALL PERMPAIRDISTS(SAVECOORDSB,DUMMYA,NATOMS,PMAXNEI,DUMMYDISTS,DUMMYIDX,NPERMGROUP)404: CALL PERMPAIRDISTS(SAVECOORDSB,DUMMYA,NATOMS,PMAXNEI,DUMMYDISTS,DUMMYIDX,NPERMGROUP)
412: 405: 
 406: !write(*,*) (dummyidx)
 407: 
413: ! Find bounded distanace matrix408: ! Find bounded distanace matrix
414: IF(BULKT) THEN409: IF(BULKT) THEN
415:     NDUMMY=0410:     NDUMMY=0
416:     DO J1=1,NPERMGROUP411:     DO J1=1,NPERMGROUP
417:         NPERM=NPERMSIZE(J1)412:         NPERM=NPERMSIZE(J1)
418:         M = MIN(NPERM,PMAXNEI)413:         M = MIN(NPERM,PMAXNEI)
419:         DUMMYLDISTS(:NPERM*M,J1) = MAX(SQRT(DUMMYDISTS(:NPERM*M,J1)) - W,0.D0)**2414:         DUMMYLDISTS(:NPERM*M,J1) = MAX(SQRT(DUMMYDISTS(:NPERM*M,J1)) - W,0.D0)**2
420:     ENDDO415:     ENDDO
421: ELSE416: ELSE
422:     NDUMMY=0417:     NDUMMY=0
462:     ELSE457:     ELSE
463:         RECALC = .FALSE.458:         RECALC = .FALSE.
464:     END IF459:     END IF
465:     ESTUPPER = UPPERBOUND460:     ESTUPPER = UPPERBOUND
466: END IF461: END IF
467: 462: 
468: 463: 
469: ! Estimating Lower Bound by finding nearest neighbours464: ! Estimating Lower Bound by finding nearest neighbours
470: IF(DEBUG.OR.(.NOT.(FORCE.OR.RECALC))) THEN465: IF(DEBUG.OR.(.NOT.(FORCE.OR.RECALC))) THEN
471:     IF(BULKT) THEN466:     IF(BULKT) THEN
 467: !        DO J1=1,NPERMGROUP
 468: !            NPERM=NPERMSIZE(J1)
 469: !            M = MIN(NPERM,PMAXNEI)
 470: !            DUMMYLDISTS(:NPERM*M,J1) = MAX(SQRT(DUMMYDISTS(:NPERM*M,J1)) - W,0.D0)**2
 471: !        ENDDO
472: 472: 
473:         ! Find relative displacements473:         ! Find relative displacements
474:         DO J1=1,NPERMGROUP474:         DO J1=1,NPERMGROUP
475:             NPERM=NPERMSIZE(J1)475:             NPERM=NPERMSIZE(J1)
476:             M = MIN(NPERM,PMAXNEI)476:             M = MIN(NPERM,PMAXNEI)
477:             DO I=1,NPERM477:             DO I=1,NPERM
478:                 IB = PERMGROUP(I+NDUMMY)478:                 IB = PERMGROUP(I+NDUMMY)
479:                 K = M*(I-1)479:                 K = M*(I-1)
480:                 DO J=1,M480:                 DO J=1,M
481:                     IA = PERMGROUP(DUMMYIDX(K+J,J1)+NDUMMY)481:                     IA = PERMGROUP(DUMMYIDX(K+J,J1)+NDUMMY)
502:                                                 & DUMMYLDISTS(:M*NPERM,J1), &502:                                                 & DUMMYLDISTS(:M*NPERM,J1), &
503:                  & MATMUL(FVECS(:,I),DUMMYDOTDISP(:,:M*NPERM,J1)).GT.0.D0)503:                  & MATMUL(FVECS(:,I),DUMMYDOTDISP(:,:M*NPERM,J1)).GT.0.D0)
504:             END DO504:             END DO
505: 505: 
506:             CALL PERMNEARESTNEIGHBOURDISTS(DUMMYLDISTS2,DUMMYIDX,NATOMS, &506:             CALL PERMNEARESTNEIGHBOURDISTS(DUMMYLDISTS2,DUMMYIDX,NATOMS, &
507:              & PMAXNEI,DUMMYNEARIDX,DUMMYNEARLDISTS,NPERMGROUP)507:              & PMAXNEI,DUMMYNEARIDX,DUMMYNEARLDISTS,NPERMGROUP)
508: 508: 
509:             D = SUM(DUMMYNEARLDISTS)509:             D = SUM(DUMMYNEARLDISTS)
510:             ESTLOWER = MIN(D, ESTLOWER)510:             ESTLOWER = MIN(D, ESTLOWER)
511: 511: 
512:             IF(DEBUG) WRITE(MYUNIT, "(A,I16,A,G10.3)") &512:             IF(DEBUG) WRITE(MYUNIT, "(A,I16,A,G20.5)") &
513:      & "gopermdist> estimating for face         = ", I, &513:      & "gopermdist> estimating for face         = ", I, &
514:      & "         lower bound = ", D**0.5514:      & "         lower bound = ", D**0.5
515:         END DO515:         END DO
516:         ESTLOWER = SQRT(ESTLOWER)516:         ESTLOWER = SQRT(ESTLOWER)
517: 517: 
518:     ELSE518:     ELSE
519:         CALL PERMNEARESTNEIGHBOURDISTS(DUMMYLDISTS,DUMMYIDX,NATOMS,PMAXNEI, &519:         CALL PERMNEARESTNEIGHBOURDISTS(DUMMYLDISTS,DUMMYIDX,NATOMS,PMAXNEI, &
520:          & DUMMYNEARIDX,DUMMYNEARLDISTS,NPERMGROUP)520:          & DUMMYNEARIDX,DUMMYNEARLDISTS,NPERMGROUP)
521: 521: 
522:         ESTLOWER = SUM(DUMMYNEARLDISTS)**0.5522:         ESTLOWER = SUM(DUMMYNEARLDISTS)**0.5
523:     END IF523:     END IF
524: 524: 
525:     LOWERBOUND = ESTLOWER525:     LOWERBOUND = ESTLOWER
526: 526: 
527:     IF(DEBUG) WRITE(MYUNIT, "(A,G20.5)") &527:     IF(DEBUG) WRITE(MYUNIT, "(A,G20.5)") &
528:      & "gopermdist> estimate for lower bound    = ", ESTLOWER528:      & "gopermdist> estimate for lower bound    = ", ESTLOWER
529: 529: 
530: END IF530: END IF
531: 531: 
532: 532: 
 533: 
 534: 
533: ! If estimate of upperbound is lower than best found upperbound we need to535: ! If estimate of upperbound is lower than best found upperbound we need to
534: ! solve assignment problem to find bounds536: ! solve assignment problem to find bounds
535: IF (FORCE.OR.RECALC) THEN537: IF (FORCE.OR.RECALC) THEN
536: 538: 
537:     ! Need to calculate this matrix to get total distance from reduced distance539:     ! Need to calculate this matrix to get total distance from reduced distance
538:     ! matrix and total permutation540:     ! matrix and total permutation
539:     CALL INVPAIRDISTIDX(DUMMYIDX, DINVIDX, NATOMS, PMAXNEI, NPERMGROUP)541:     CALL INVPAIRDISTIDX(DUMMYIDX, DINVIDX, NATOMS, PMAXNEI, NPERMGROUP)
540: 542: 
 543: !    DINVIDX = -1
 544: !    DO J1=1,NPERMGROUP
 545: !        NPERM = NPERMSIZE(J1)
 546: !        M = MIN(NPERM,PMAXNEI)
 547: !        DO J=1,NPERM
 548: !            K=M*(J-1)
 549: !            K1 = NPERM*(J-1)
 550: !            DO I=1,M
 551: !                DINVIDX(K1+DUMMYIDX(K+I,J1),J1) = I
 552: !            END DO
 553: !        END DO
 554: !    END DO
 555: 
541:     IF(BULKT) THEN556:     IF(BULKT) THEN
542:         DO J1=1,NPERMGROUP557:         DO J1=1,NPERMGROUP
543:             NPERM=NPERMSIZE(J1)558:             NPERM=NPERMSIZE(J1)
 559: !            M = MERGE(NPERM,PMAXNEI,NPERM.LT.PMAXNEI)
544:             M = MIN(NPERM,PMAXNEI)560:             M = MIN(NPERM,PMAXNEI)
545:             DUMMYLDISTS(:NPERM*M,J1) = MAX(SQRT(DUMMYDISTS(:NPERM*M,J1)) - W,0.D0)**2561:             DUMMYLDISTS(:NPERM*M,J1) = MAX(SQRT(DUMMYDISTS(:NPERM*M,J1)) - W,0.D0)**2
546:         ENDDO562:         ENDDO
547:     END IF563:     END IF
548: 564: 
549:     CALL FINDBESTPERM(DUMMYLDISTS,DUMMYIDX,NATOMS,PMAXNEI,NEWPERM, &565:     CALL FINDBESTPERM(DUMMYLDISTS,DUMMYIDX,NATOMS,PMAXNEI,NEWPERM, &
550:      & LOWERBOUND,NPERMGROUP, INFO)566:      & LOWERBOUND,NPERMGROUP, INFO)
551: 567: 
552:     CALL FINDPERMVAL(NEWPERM,NATOMS,DUMMYLDISTS,DINVIDX,PMAXNEI,NPERMGROUP,LOWERBOUND)568:     CALL FINDPERMVAL(NEWPERM,NATOMS,DUMMYLDISTS,DINVIDX,PMAXNEI,NPERMGROUP,LOWERBOUND)
 569: !    LOWERBOUND = 0.D0
 570: !    NDUMMY = 0
 571: !    DO J1=1,NPERMGROUP
 572: !        NPERM = NPERMSIZE(J1)
 573: !        M = MIN(NPERM,PMAXNEI)
 574: !        DO J=1,NPERM
 575: !!            K = M*(J-1)
 576: !!            K1 = NPERM*(J-1)
 577: !            IA = INVPERMGROUP(NEWPERM(PERMGROUP(J+NDUMMY)))-NDUMMY
 578: !            I = DINVIDX(NPERM*(J-1)+IA,J1)
 579: !            LOWERBOUND = LOWERBOUND + DUMMYLDISTS(M*(J-1)+I,J1)
 580: !        END DO
 581: !        NDUMMY = NDUMMY + NPERM
 582: !    END DO
 583: 
 584: !    LOWERBOUND = 0.D0
 585: !    ! Perhaps there's a better way of calculating lowerbound from FINDBESTPERM?
 586: !    DO J=1,NATOMS
 587: !        I = NEWPERM(J)
 588: !        LOWERBOUND = (LOWERBOUND + MAX(SQRT(PERMDIST( &
 589: !         & SAVECOORDSB(3*J-2:3*J),DUMMYA(3*I-2:3*I),BOXVEC,BULKT))-W,0.D0)**2)
 590: !    END DO
553: 591: 
554:     ! Check output of assignment problem592:     ! Check output of assignment problem
555:     IF(INFO.GT.0) THEN593:     IF(INFO.GT.0) THEN
556:         LOWERBOUND = 0.D0594:         LOWERBOUND = 0.D0
557:         IF(DEBUG) WRITE(MYUNIT, "(A,I3)") &595:         IF(DEBUG) WRITE(MYUNIT, "(A,I3)") &
558:  & "gopermdist> WARNING LAP algorithm failed to align npoints= ", INFO596:  & "gopermdist> WARNING LAP algorithm failed to align npoints= ", INFO
559:     ELSE597:     ELSE
560:         LOWERBOUND = SQRT(LOWERBOUND)598:         LOWERBOUND = SQRT(LOWERBOUND)
561:         IF(DEBUG) WRITE(MYUNIT, "(A,G20.5)") &599:         IF(DEBUG) WRITE(MYUNIT, "(A,G20.5)") &
562:  & "gopermdist> calculated lower bound RMSD = ", LOWERBOUND600:  & "gopermdist> calculated lower bound RMSD = ", LOWERBOUND
563:     END IF601:     END IF
564:     ! Calculate upperbound if lowerbound lower than bestupper602:     ! Calculate upperbound if lowerbound lower than bestupper
565:     IF((LOWERBOUND.LT.BESTUPPER).OR.FORCE) THEN603:     IF((LOWERBOUND.LT.BESTUPPER).OR.FORCE) THEN
566:         CALL FINDBESTPERM(DUMMYDISTS,DUMMYIDX,NATOMS,PMAXNEI,LPERM, &604:         CALL FINDBESTPERM(DUMMYDISTS,DUMMYIDX,NATOMS,PMAXNEI,LPERM, &
567:          & UPPERBOUND,NPERMGROUP, INFO)605:          & UPPERBOUND,NPERMGROUP, INFO)
568: 606: 
569:         CALL FINDPERMVAL(LPERM,NATOMS,DUMMYDISTS,DINVIDX,PMAXNEI,NPERMGROUP,UPPERBOUND)607:         CALL FINDPERMVAL(LPERM,NATOMS,DUMMYDISTS,DINVIDX,PMAXNEI,NPERMGROUP,UPPERBOUND)
570: 608: 
 609: !        UPPERBOUND = 0.D0
 610: !        NDUMMY = 0
 611: !        DO J1=1,NPERMGROUP
 612: !            NPERM = NPERMSIZE(J1)
 613: !            M = MIN(NPERM,PMAXNEI)
 614: !            DO J=1,NPERM
 615: !!                K = M*(J-1)
 616: !!                K1 = NPERM*(J-1)
 617: !                IA = INVPERMGROUP(NEWPERM(PERMGROUP(J+NDUMMY)))-NDUMMY
 618: !                I = DINVIDX(NPERM*(J-1)+IA,J1)
 619: !                UPPERBOUND = UPPERBOUND + DUMMYDISTS(M*(J-1)+I,J1)
 620: !            END DO
 621: !            NDUMMY = NDUMMY + NPERM
 622: !        END DO
 623: 
 624: !        UPPERBOUND = 0.D0
 625: !        DO J=1,NATOMS
 626: !            I = LPERM(J)
 627: !            UPPERBOUND = (UPPERBOUND + PERMDIST( &
 628: !         & SAVECOORDSB(3*J-2:3*J),DUMMYA(3*I-2:3*I),BOXVEC,BULKT))
 629: !        END DO
 630: 
571:         ! Check output of assignment problem631:         ! Check output of assignment problem
572:         IF(INFO.GT.0) THEN632:         IF(INFO.GT.0) THEN
573:             UPPERBOUND = HUGE(1.D0)633:             UPPERBOUND = HUGE(1.D0)
574:             IF(DEBUG) WRITE(MYUNIT, "(A,I3)") &634:             IF(DEBUG) WRITE(MYUNIT, "(A,I3)") &
575:  & "gopermdist> WARNING LAP algorithm failed to align npoints= ", INFO635:  & "gopermdist> WARNING LAP algorithm failed to align npoints= ", INFO
576:         ELSE636:         ELSE
577:             UPPERBOUND = SQRT(UPPERBOUND)637:             UPPERBOUND = SQRT(UPPERBOUND)
578:             IF(DEBUG) WRITE(MYUNIT, "(A,G20.5)") &638:             IF(DEBUG) WRITE(MYUNIT, "(A,G20.5)") &
579:  & "gopermdist> calculated upper bound RMSD = ", UPPERBOUND639:  & "gopermdist> calculated upper bound RMSD = ", UPPERBOUND
580:         END IF640:         END IF
587:     WRITE(MYUNIT,"(A)") "gopermdist>************WARNING*********************"647:     WRITE(MYUNIT,"(A)") "gopermdist>************WARNING*********************"
588:     WRITE(MYUNIT,"(A)") "EST UPPER GT UPPERBOUND OR EST LOWER GT LOWERBOUND"648:     WRITE(MYUNIT,"(A)") "EST UPPER GT UPPERBOUND OR EST LOWER GT LOWERBOUND"
589:     WRITE(MYUNIT,"(A)") "gopermdist>************WARNING*********************"649:     WRITE(MYUNIT,"(A)") "gopermdist>************WARNING*********************"
590:     NBAD = NBAD + 1650:     NBAD = NBAD + 1
591: ENDIF651: ENDIF
592: 652: 
593: NCALC = NCALC + 1653: NCALC = NCALC + 1
594: 654: 
595: END SUBROUTINE CALCBOUNDS655: END SUBROUTINE CALCBOUNDS
596: 656: 
597: SUBROUTINE FINDPERMVAL(PERM, NCOORDS, MATVALS, DINVIDX, MAXNEI, NPERMGROUPS, BEST)657: SUBROUTINE FINDPERMVAL(PERM, NATOMS, MATVALS, DINVIDX, MAXNEI, NPERMGROUP, BEST)
598: 658: 
599: IMPLICIT NONE659: IMPLICIT NONE
600: INTEGER, INTENT(IN) :: NCOORDS, MAXNEI, NPERMGROUPS660: INTEGER, INTENT(IN) :: NATOMS, NPERMGROUP, PERM(NATOMS), DINVIDX(NATOMS*NATOMS,NPERMGROUP), &
601: INTEGER, INTENT(IN) :: PERM(NCOORDS), DINVIDX(NCOORDS*NCOORDS,NPERMGROUPS)661:  & MAXNEI
602: DOUBLE PRECISION, INTENT(IN) :: MATVALS(NCOORDS*MAXNEI,NPERMGROUPS)662: DOUBLE PRECISION, INTENT(IN) :: MATVALS(NATOMS*MAXNEI,NPERMGROUP)
603: DOUBLE PRECISION, INTENT(OUT) :: BEST663: DOUBLE PRECISION, INTENT(OUT) :: BEST
604: 664: 
605: INTEGER J1,M,J,I,IA,NPERM,NDUMMY665: INTEGER J1,M,J,I,IA,NPERM,NDUMMY
606: 666: 
607: IF (NPERMGROUP.NE.NPERMGROUPS) THEN 
608:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
609:     STOP 
610: ENDIF 
611:  
612: BEST = 0.D0667: BEST = 0.D0
613: NDUMMY = 0668: NDUMMY = 0
614: DO J1=1,NPERMGROUP669: DO J1=1,NPERMGROUP
615:     NPERM = NPERMSIZE(J1)670:     NPERM = NPERMSIZE(J1)
616:     M = MIN(NPERM,MAXNEI)671:     M = MIN(NPERM,MAXNEI)
617:     DO J=1,NPERM672:     DO J=1,NPERM
618:         IA = INVPERMGROUP(PERM(PERMGROUP(J+NDUMMY)))-NDUMMY673:         IA = INVPERMGROUP(PERM(PERMGROUP(J+NDUMMY)))-NDUMMY
619:         I = DINVIDX(NPERM*(J-1)+IA,J1)674:         I = DINVIDX(NPERM*(J-1)+IA,J1)
620:         BEST = BEST + MATVALS(M*(J-1)+I,J1)675:         BEST = BEST + MATVALS(M*(J-1)+I,J1)
621:     END DO676:     END DO
622:     NDUMMY = NDUMMY + NPERM677:     NDUMMY = NDUMMY + NPERM
623: END DO678: END DO
624: 679: 
625: END SUBROUTINE FINDPERMVAL680: END SUBROUTINE FINDPERMVAL
626: 681: 
627: SUBROUTINE INVPAIRDISTIDX(DUMMYIDX, DINVIDX, NCOORDS, MAXNEI, NPERMGROUPS)682: SUBROUTINE INVPAIRDISTIDX(DUMMYIDX, DINVIDX, NATOMS, MAXNEI, NPERMGROUP)
628: 683: 
629: IMPLICIT NONE684: IMPLICIT NONE
630: INTEGER, INTENT(IN) :: NCOORDS, MAXNEI, NPERMGROUPS685: INTEGER, INTENT(IN) :: NATOMS, MAXNEI, NPERMGROUP, DUMMYIDX(NATOMS*MAXNEI,NPERMGROUP)
631: INTEGER, INTENT(IN) :: DUMMYIDX(NCOORDS*MAXNEI,NPERMGROUPS)686: INTEGER, INTENT(OUT) :: DINVIDX(NATOMS*NATOMS,NPERMGROUP)
632: INTEGER, INTENT(OUT) :: DINVIDX(NCOORDS*NCOORDS,NPERMGROUPS) 
633: INTEGER J1,NPERM,I,J,M687: INTEGER J1,NPERM,I,J,M
634: 688: 
635: IF (NPERMGROUP.NE.NPERMGROUPS) THEN 
636:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
637:     STOP 
638: ENDIF 
639:  
640: DINVIDX = -1689: DINVIDX = -1
641: DO J1=1,NPERMGROUP690: DO J1=1,NPERMGROUP
642:     NPERM = NPERMSIZE(J1)691:     NPERM = NPERMSIZE(J1)
643:     M = MIN(NPERM,MAXNEI)692:     M = MIN(NPERM,MAXNEI)
644:     DO J=1,NPERM693:     DO J=1,NPERM
645:         DO I=1,M694:         DO I=1,M
646:             DINVIDX(NPERM*(J-1)+DUMMYIDX(M*(J-1)+I,J1),J1) = I695:             DINVIDX(NPERM*(J-1)+DUMMYIDX(M*(J-1)+I,J1),J1) = I
647:         END DO696:         END DO
648:     END DO697:     END DO
649: END DO698: END DO
650: 699: 
651: END SUBROUTINE INVPAIRDISTIDX700: END SUBROUTINE INVPAIRDISTIDX
652: 701: 
653: SUBROUTINE PERMNEARESTNEIGHBOURDISTS(NDISTS,NIDX,NCOORDS,MAXNEI,NEARI,NEARD,NPERMGROUPS)702: SUBROUTINE PERMNEARESTNEIGHBOURDISTS(NDISTS,NIDX,NATOMS,MAXNEI,NEARI,NEARD,NPERMGROUP)
654: 703: 
655: IMPLICIT NONE704: IMPLICIT NONE
656: INTEGER, INTENT(IN) :: NCOORDS,MAXNEI,NPERMGROUPS,NIDX(MAXNEI*NCOORDS,NPERMGROUPS)705: INTEGER, INTENT(IN) :: NATOMS,MAXNEI,NPERMGROUP,NIDX(MAXNEI*NATOMS,NPERMGROUP)
657: DOUBLE PRECISION, INTENT(IN) :: NDISTS(MAXNEI*NCOORDS,NPERMGROUPS)706: DOUBLE PRECISION, INTENT(IN) :: NDISTS(MAXNEI*NATOMS,NPERMGROUP)
658: 707: 
659: INTEGER, INTENT(OUT) :: NEARI(NCOORDS)708: INTEGER, INTENT(OUT) :: NEARI(NATOMS)
660: DOUBLE PRECISION, INTENT(OUT) :: NEARD(NCOORDS)709: DOUBLE PRECISION, INTENT(OUT) :: NEARD(NATOMS)
661: 710: 
662: INTEGER I, J1, J2, IND, NPERM, NDUMMY, M711: INTEGER I, J1, J2, IND, NPERM, NDUMMY, M
663: 712: 
664: IF (NPERMGROUP.NE.NPERMGROUPS) THEN 
665:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
666:     STOP 
667: ENDIF 
668:  
669: NDUMMY = 0713: NDUMMY = 0
670: DO J1=1,NPERMGROUP714: DO J1=1,NPERMGROUP
671:     NPERM=NPERMSIZE(J1)715:     NPERM=NPERMSIZE(J1)
672: !    M = MERGE(NPERM,MAXNEI,NPERM.LT.MAXNEI)716: !    M = MERGE(NPERM,MAXNEI,NPERM.LT.MAXNEI)
673:     M = MIN(NPERM,PMAXNEI)717:     M = MIN(NPERM,PMAXNEI)
674:     CALL NEARESTNEIGHBOURDISTS(NDISTS(1:NPERM*M,J1),NIDX(1:NPERM*M,J1), &718:     CALL NEARESTNEIGHBOURDISTS(NDISTS(1:NPERM*M,J1),NIDX(1:NPERM*M,J1), &
675:  & NPERM,M,LPERM(1:NPERM),PDUMMYND(1:NPERM))719:  & NPERM,M,LPERM(1:NPERM),PDUMMYND(1:NPERM))
676: 720: 
677:     DO J2=1,NPERM721:     DO J2=1,NPERM
678:         IND = LPERM(J2)722:         IND = LPERM(J2)
700: IF(N.LT.MAXNEI) M=N744: IF(N.LT.MAXNEI) M=N
701: 745: 
702: DO I=1,N746: DO I=1,N
703:     J = MINLOC(CC(M*(I-1)+1:M*I),1)747:     J = MINLOC(CC(M*(I-1)+1:M*I),1)
704:     DISTS(I) = CC(M*(I-1) + J)748:     DISTS(I) = CC(M*(I-1) + J)
705:     IDX(I)   = KK(M*(I-1) + J)749:     IDX(I)   = KK(M*(I-1) + J)
706: END DO750: END DO
707: 751: 
708: END SUBROUTINE NEARESTNEIGHBOURDISTS752: END SUBROUTINE NEARESTNEIGHBOURDISTS
709: 753: 
 754: SUBROUTINE FINDBESTPERM(NDISTS,NIDX,NATOMS,MAXNEI,PERM,DIST,NPERMGROUP,INFO)
 755: ! DISTANCE RETURN INACCURATE
 756: IMPLICIT NONE
 757: 
 758: INTEGER, INTENT(IN) :: NATOMS,NPERMGROUP,MAXNEI,NIDX(MAXNEI*NATOMS,NPERMGROUP)
 759: DOUBLE PRECISION, INTENT(IN) :: NDISTS(MAXNEI*NATOMS,NPERMGROUP)
 760: 
 761: DOUBLE PRECISION, INTENT(OUT) :: DIST
 762: INTEGER, INTENT(OUT) :: PERM(NATOMS), INFO
 763: 
 764: ! COULD SET THESE AS MODULE VARIABLES
 765: INTEGER(KIND=INT64) :: KK(NATOMS*MAXNEI), CC(NATOMS*MAXNEI)
 766: INTEGER(KIND=INT64) :: FIRST(NATOMS+1), X(NATOMS), Y(NATOMS)
 767: INTEGER(KIND=INT64) :: U(NATOMS), V(NATOMS), N8, SZ8, H
 768: INTEGER N,M,I,J,K,K1,I1,J1,NDUMMY
 769: 
 770: DIST = 0.D0
 771: INFO=0
 772: 
 773: NDUMMY=0
 774: 
 775: DO J1=1,NPERMGROUP
 776: 
 777:     N = NPERMSIZE(J1)
 778:     M = MAXNEI
 779:     IF(N.LE.MAXNEI) M=N
 780:     SZ8 = M*N
 781:     N8 = N
 782: 
 783:     DO I=0,N
 784:         FIRST(I+1) = I*M +1
 785:     ENDDO
 786:     KK = -1
 787:     CC = HUGE(1)
 788:     DO J=1,N
 789:         K = FIRST(J)-1
 790:         DO I=1,M
 791:             KK(I+K) = NIDX(I+K,J1)
 792:             CC(I+K) = INT(NDISTS(I+K,J1)*PSCALE, 8)
 793:         ENDDO
 794:     ENDDO
 795: 
 796:     CALL JOVOSAP(N8, SZ8, CC(:M*N), KK(:M*N), FIRST(:N+1), Y(:N), X(:N), U(:N), V(:N), H)
 797:     NLAP = NLAP + 1
 798: 
 799:     DO I=1,N
 800:         IF (Y(I).GT.N) THEN
 801:             Y(I)=N
 802:             INFO = INFO + 1
 803:         END IF
 804:         IF (Y(I).LT.1) THEN
 805:             Y(I)=1
 806:             INFO = INFO + 1
 807:         END IF
 808:         PERM(PERMGROUP(NDUMMY+I)) = PERMGROUP(NDUMMY+Y(I))
 809:     ENDDO
 810:     DIST = DIST + H/PSCALE
 811: 
 812:     ! untested!!
 813:     IF (NSETS(J1).GT.0) THEN
 814:         DO I=1,N
 815:             DO K=1,NSETS(J1)
 816:                 PERM(SETS(PERMGROUP(NDUMMY+I),K))=SETS(PERM(PERMGROUP(NDUMMY+Y(I))),K)
 817:             ENDDO
 818:         ENDDO
 819:     ENDIF
 820: 
 821:     NDUMMY = NDUMMY + NPERMSIZE(J1)
 822: ENDDO
 823: 
 824: 
 825: END SUBROUTINE FINDBESTPERM
 826: 
 827: SUBROUTINE PERMPAIRDISTS(COORDSB,COORDSA,NATOMS,MAXNEI,NDISTS,NIDX,NPERMGROUP)
 828: 
 829: ! Uses module variables BOXLX, BOXLY, BOXLZ, BULKT when calculating periodic distances
 830: 
 831: IMPLICIT NONE
 832: 
 833: INTEGER, INTENT(IN) :: NATOMS, NPERMGROUP, MAXNEI
 834: DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NATOMS), COORDSB(3*NATOMS)
 835: 
 836: INTEGER, INTENT(OUT) :: NIDX(MAXNEI*NATOMS,NPERMGROUP)
 837: DOUBLE PRECISION, INTENT(OUT) :: NDISTS(MAXNEI*NATOMS,NPERMGROUP)
 838: 
 839: INTEGER NDUMMY,J1,J2,NPERM
 840: 
 841: NDUMMY = 0
 842: 
 843: NIDX   = -1
 844: NDISTS = HUGE(1.D0)
 845: 
 846: DO J1=1,NPERMGROUP
 847:     NPERM=NPERMSIZE(J1)
 848:     DO J2=1,NPERM
 849:         PDUMMYA(3*(J2-1)+1)=COORDSA(3*((PERMGROUP(NDUMMY+J2))-1)+1)
 850:         PDUMMYA(3*(J2-1)+2)=COORDSA(3*((PERMGROUP(NDUMMY+J2))-1)+2)
 851:         PDUMMYA(3*(J2-1)+3)=COORDSA(3*((PERMGROUP(NDUMMY+J2))-1)+3)
 852:         PDUMMYB(3*(J2-1)+1)=COORDSB(3*((PERMGROUP(NDUMMY+J2))-1)+1)
 853:         PDUMMYB(3*(J2-1)+2)=COORDSB(3*((PERMGROUP(NDUMMY+J2))-1)+2)
 854:         PDUMMYB(3*(J2-1)+3)=COORDSB(3*((PERMGROUP(NDUMMY+J2))-1)+3)
 855:     ENDDO
 856:     CALL PAIRDISTS(NPERM,PDUMMYB(1:3*NPERM),PDUMMYA(1:3*NPERM),BOXLX,BOXLY, &
 857:  & BOXLZ,BULKT,NDISTS(1:MAXNEI*NPERM,J1),NIDX(1:MAXNEI*NPERM,J1),MAXNEI)
 858:     NDUMMY = NDUMMY + NPERM
 859: ENDDO
 860: 
 861: END SUBROUTINE PERMPAIRDISTS
 862: 
710: FUNCTION BOUNDROTDISTANCE(D2,COSW,SINW,RA,RB) RESULT(LDIST)863: FUNCTION BOUNDROTDISTANCE(D2,COSW,SINW,RA,RB) RESULT(LDIST)
711: 864: 
712: IMPLICIT NONE865: IMPLICIT NONE
713: DOUBLE PRECISION, INTENT(IN) :: D2,COSW,SINW,RA,RB866: DOUBLE PRECISION, INTENT(IN) :: D2,COSW,SINW,RA,RB
714: DOUBLE PRECISION LDIST867: DOUBLE PRECISION LDIST
715: 868: 
716: DOUBLE PRECISION RARB,RA2RB2,COSAB,SINAB,MCOSAB869: DOUBLE PRECISION RARB,RA2RB2,COSAB,SINAB,MCOSAB
717: 870: 
718: ! Precalculate these?871: ! Precalculate these?
719: RARB = 2*RA*RB872: RARB = 2*RA*RB
776: 929: 
777: IMPLICIT NONE930: IMPLICIT NONE
778: TYPE(NODE) RES931: TYPE(NODE) RES
779: 932: 
780: DO WHILE(Q%N.GT.0)933: DO WHILE(Q%N.GT.0)
781:     RES = TOP(Q)934:     RES = TOP(Q)
782: END DO935: END DO
783: 936: 
784: END SUBROUTINE QUEUECLEAR937: END SUBROUTINE QUEUECLEAR
785: 938: 
786: SUBROUTINE INITIALISE(COORDSB,COORDSA,NCOORDS,NBOXLX,NBOXLY,NBOXLZ,NBULKT)939: SUBROUTINE INITIALISE(COORDSB,COORDSA,NATOMS,NBOXLX,NBOXLY,NBOXLZ,NBULKT)
787:  
788: USE ALIGNUTILS, ONLY: OHOPS 
789: 940: 
 941: !USE COMMONS, ONLY: PERMINVOPT, OHCELLT
790: IMPLICIT NONE942: IMPLICIT NONE
791: 943: 
792: INTEGER, INTENT(IN) :: NCOORDS944: INTEGER, INTENT(IN) :: NATOMS
793: DOUBLE PRECISION, INTENT(IN) :: COORDSB(3*NCOORDS), COORDSA(3*NCOORDS), &945: DOUBLE PRECISION, INTENT(IN) :: COORDSB(3*NATOMS), COORDSA(3*NATOMS), &
794:  & NBOXLX, NBOXLY, NBOXLZ946:  & NBOXLX, NBOXLY, NBOXLZ
795: LOGICAL, INTENT(IN) :: NBULKT947: LOGICAL, INTENT(IN) :: NBULKT
796: 948: 
797: DOUBLE PRECISION BVEC(3)949: DOUBLE PRECISION BVEC(3)
798: INTEGER I, J, K, IND, NUMSTRUCTS950: INTEGER I, J, K, IND, NDUMMY, NUMSTRUCTS
799: 951: 
800: NATOMS = NCOORDS 
801: BOXLX = NBOXLX952: BOXLX = NBOXLX
802: BOXLY = NBOXLY953: BOXLY = NBOXLY
803: BOXLZ = NBOXLZ954: BOXLZ = NBOXLZ
804: BOXVEC = (/BOXLX,BOXLY,BOXLZ/)955: BOXVEC = (/BOXLX,BOXLY,BOXLZ/)
805: BULKT = NBULKT956: BULKT = NBULKT
806: 957: 
807: NCALC   = 0958: NCALC   = 0
808: NLAP    = 0959: NLAP    = 0
809: NQUENCH = 0960: NQUENCH = 0
810: NBAD = 0961: NBAD = 0
811: 962: 
812: ! --------------------------------------------------------------------------- !963: ! --------------------------------------------------------------------------- !
813: !    allocating memory to arrays964: !    allocating memory to arrays
814: ! --------------------------------------------------------------------------- !965: ! --------------------------------------------------------------------------- !
815: 966: 
816: NUMSTRUCTS = 1967: NUMSTRUCTS = 1
817: IF (PERMINVOPT.AND.(.NOT.BULKT)) NUMSTRUCTS = 2968: IF (PERMINVOPT) THEN
818: IF (BULKT.AND.OHCELLT) NUMSTRUCTS = 48969:     NUMSTRUCTS = 2
819: 970: ELSE IF (BULKT.AND.OHCELLT) THEN
 971:     NUMSTRUCTS = 48
 972: ENDIF
820: 973: 
821: CALL REALLOCATEARRAYS(NATOMS, NUMSTRUCTS, BULKT)974: CALL REALLOCATEARRAYS(NATOMS, NUMSTRUCTS, BULKT)
822: 975: 
823: ! --------------------------------------------------------------------------- !976: ! --------------------------------------------------------------------------- !
824: !    calculate inverse permutation group977: !    calculate inverse permutation group
825: ! --------------------------------------------------------------------------- !978: ! --------------------------------------------------------------------------- !
826: 979: 
827: DO I=1,NATOMS980: DO I=1,NATOMS
828:     INVPERMGROUP(PERMGROUP(I)) = I981:     INVPERMGROUP(PERMGROUP(I)) = I
829: END DO982: END DO
830: 983: 
831: ! --------------------------------------------------------------------------- !984: ! --------------------------------------------------------------------------- !
832: !    storing coordinates to module985: !    storing coordinates to module
833: ! --------------------------------------------------------------------------- !986: ! --------------------------------------------------------------------------- !
834: 987: 
 988: NDUMMY = 0
835: IF(BULKT) THEN989: IF(BULKT) THEN
 990: !    Needed for k-d trees stuff
 991: !    DO I=1,NPERMGROUP
 992: !        DO J=1, NPERMSIZE(I)
 993: !            IND = PERMGROUP(NDUMMY+J)
 994: !            SAVECOORDSB(3*IND-2) = COORDSB(3*IND-2) - BOXLX*ANINT(COORDSB(3*IND-2)/BOXLX)
 995: !            SAVECOORDSB(3*IND-1) = COORDSB(3*IND-1) - BOXLY*ANINT(COORDSB(3*IND-1)/BOXLY)
 996: !            SAVECOORDSB(3 * IND) = COORDSB(3 * IND) - BOXLZ*ANINT(COORDSB(3 * IND)/BOXLZ)
 997: !        ENDDO
 998: !    NDUMMY = NDUMMY + NPERMSIZE(I)
 999: !    ENDDO
836:     SAVECOORDSB = COORDSB1000:     SAVECOORDSB = COORDSB
837:     IF(OHCELLT) THEN1001:     IF(OHCELLT) THEN
838:         DO I=1,481002:         DO I=1,48
839:             CALL OHOPS(COORDSA,SAVECOORDSA(:,I),I,NATOMS)1003:             CALL OHOPS(COORDSA,SAVECOORDSA(:,I),I,NATOMS)
840:         END DO1004:         END DO
841:     ELSE1005:     ELSE
842:         SAVECOORDSA(:,1) = COORDSA1006:         SAVECOORDSA(:,1) = COORDSA
843:     END IF1007:     END IF
844: ELSE1008: ELSE
845:     ! Calculate COM1009:     ! Calculate COM
872:         SAVERA(I,1) = SQRT(SAVECOORDSA(3*I-2,1)**2+SAVECOORDSA(3*I-1,1)**2+ &1036:         SAVERA(I,1) = SQRT(SAVECOORDSA(3*I-2,1)**2+SAVECOORDSA(3*I-1,1)**2+ &
873:                          & SAVECOORDSA(3 * I,1)**2)1037:                          & SAVECOORDSA(3 * I,1)**2)
874:     ENDDO1038:     ENDDO
875:     ! Store inverted configuration1039:     ! Store inverted configuration
876:     IF (PERMINVOPT) THEN1040:     IF (PERMINVOPT) THEN
877:         SAVECOORDSA(:,2) = -SAVECOORDSA(:,1)1041:         SAVECOORDSA(:,2) = -SAVECOORDSA(:,1)
878:         SAVERA(:,2) = SAVERA(:,1)1042:         SAVERA(:,2) = SAVERA(:,1)
879:     END IF1043:     END IF
880: END IF1044: END IF
881: 1045: 
 1046: ! --------------------------------------------------------------------------- !
 1047: ! Allocate and populate k-d trees, should be a faster way of finding nearest
 1048: ! neighbours, currently isn't...
 1049: ! --------------------------------------------------------------------------- !
 1050: 
 1051: !IF(ALLOCATED(KDTREES)) DEALLOCATE(KDTREES)
 1052: !ALLOCATE(KDTREES(NPERMGROUP))
 1053: !NDUMMY = 0
 1054: !DO I=1,NPERMGROUP
 1055: !    IF(BULKT) THEN
 1056: !    DO K=0,8
 1057: !        BVEC(1) = BOXLX*LVECS(1,K)
 1058: !        BVEC(2) = BOXLY*LVECS(2,K)
 1059: !        BVEC(3) = BOXLZ*LVECS(3,K)
 1060: !        DO J=1, NPERMSIZE(I)
 1061: !            IND = PERMGROUP(NDUMMY+J)
 1062: !            PERMCOORDSB(1,J+K*NPERMSIZE(I),I) = SAVECOORDSB(3*IND-2) + BVEC(1)
 1063: !            PERMCOORDSB(2,J+K*NPERMSIZE(I),I) = SAVECOORDSB(3*IND-1) + BVEC(2)
 1064: !            PERMCOORDSB(3,J+K*NPERMSIZE(I),I) = SAVECOORDSB(3*IND) + BVEC(3)
 1065: !        ENDDO
 1066: !    ENDDO
 1067: !    KDTREES(I)%TREE => KDTREE2_CREATE(PERMCOORDSB(:,:NPERMSIZE(I)*9,I),NPERMSIZE(I)*9,.true.,.true.)
 1068: !    ELSE
 1069: !        DO J=1, NPERMSIZE(I)
 1070: !            IND = PERMGROUP(NDUMMY+J)
 1071: !            PERMCOORDSB(:,J,I)=COORDSB(3*IND-2:3*IND) - (/CMBX,CMBY,CMBZ/)
 1072: !        ENDDO
 1073: !        KDTREES(I)%TREE => KDTREE2_CREATE(PERMCOORDSB(:,:NPERMSIZE(I),I),NPERMSIZE(I),.true.,.true.)
 1074: !    END IF
 1075: !    NDUMMY = NDUMMY + NPERMSIZE(I)
 1076: !ENDDO
 1077: 
882: CALL QUEUECLEAR()1078: CALL QUEUECLEAR()
883: 1079: 
884: END SUBROUTINE INITIALISE1080: END SUBROUTINE INITIALISE
885: 1081: 
886: SUBROUTINE SETNATOMS(NEWNATOMS)1082: SUBROUTINE SETNATOMS(NEWNATOMS)
887: ! Checks if arrays need to be (re)allocated1083: ! Checks if arrays need to be (re)allocated
888: IMPLICIT NONE1084: IMPLICIT NONE
889: 1085: 
890: INTEGER, INTENT(IN) :: NEWNATOMS1086: INTEGER, INTENT(IN) :: NEWNATOMS
891: 1087: 
 1088: NATOMS = NEWNATOMS  ! This sets the value of NATOMS that will be SAVE'd in this module.
892: IF(.NOT.(SIZE(PDUMMYA).EQ.(3*NEWNATOMS))) THEN1089: IF(.NOT.(SIZE(PDUMMYA).EQ.(3*NEWNATOMS))) THEN
893:     IF(ALLOCATED(PDUMMYA)) THEN1090:     IF(ALLOCATED(PDUMMYA)) THEN
894:         DEALLOCATE(PDUMMYA,PDUMMYB,DUMMYA,DUMMYB,XBESTA,XBESTASAVE)1091:         DEALLOCATE(PDUMMYA,PDUMMYB,DUMMYA,DUMMYB,XBESTA,XBESTASAVE)
895:         DEALLOCATE(NEWPERM, LPERM)1092:         DEALLOCATE(NEWPERM, LPERM)
896:     ENDIF1093:     ENDIF
897:     ALLOCATE(PDUMMYA(3*NEWNATOMS),PDUMMYB(3*NEWNATOMS),DUMMYA(3*NEWNATOMS), &1094:     ALLOCATE(PDUMMYA(3*NEWNATOMS),PDUMMYB(3*NEWNATOMS),DUMMYA(3*NEWNATOMS), &
898:     &   DUMMYB(3*NEWNATOMS), XBESTA(3*NEWNATOMS), XBESTASAVE(3*NEWNATOMS))1095:     &   DUMMYB(3*NEWNATOMS), XBESTA(3*NEWNATOMS), XBESTASAVE(3*NEWNATOMS))
899:     ALLOCATE(NEWPERM(NEWNATOMS), LPERM(NEWNATOMS))1096:     ALLOCATE(NEWPERM(NEWNATOMS), LPERM(NEWNATOMS))
900: ENDIF1097: ENDIF
901: 1098: 
946: 1143: 
947: CALL SETNATOMS(NEWNATOMS)1144: CALL SETNATOMS(NEWNATOMS)
948: 1145: 
949: NATOMS = NEWNATOMS1146: NATOMS = NEWNATOMS
950: PERMGROUP = NEWPERMGROUP1147: PERMGROUP = NEWPERMGROUP
951: NPERMSIZE = NEWNPERMSIZE1148: NPERMSIZE = NEWNPERMSIZE
952: NSETS = 01149: NSETS = 0
953: 1150: 
954: END SUBROUTINE SETPERM1151: END SUBROUTINE SETPERM
955: 1152: 
 1153: SUBROUTINE PAIRDISTS(n, p, q, sx, sy, sz, pbc, cc, kk, maxnei)
 1154:       implicit none
 1155: 
 1156: !     Input
 1157: !       n  : System size
 1158: !       p,q: Coordinate vectors (n particles)
 1159: !       s  : Box lengths (or dummy if open B.C.)
 1160: !       pbc: Periodic boundary conditions?
 1161:       integer, intent(in) :: n, maxnei
 1162:       double precision, intent(in) :: p(3*n), q(3*n), sx, sy, sz
 1163:       logical, intent(in) :: pbc
 1164:       double precision s(3)
 1165: 
 1166: !     Output
 1167: !       perm: Permutation so that p(i) <--> q(perm(i))
 1168: !       dist: Minimum attainable distance
 1169: !     We have
 1170:       double precision, intent(out) :: cc(n*maxnei)
 1171:       integer, intent(out) :: kk(n*maxnei)
 1172:       double precision DUMMY
 1173: 
 1174: !     Parameters
 1175: !       scale : Precision
 1176: !       maxnei: Maximum number of closest neighbours
 1177:       double precision scale, d, h
 1178: 
 1179:       parameter (scale = 1.0d6   )
 1180: !      parameter (maxnei = 60     )
 1181: 
 1182:       integer(kind=INT64) first(n+1)!, x(n), y(n)
 1183: !      integer(kind=INT64) u(n), v(n)
 1184:       integer   m, i, j, k, l, l2, t, a
 1185:       integer(kind=INT64) n8, sz8
 1186:       integer J1
 1187: 
 1188: !     Distance function
 1189:       double precision permdist
 1190: 
 1191:       s(1)=sx
 1192:       s(2)=sy
 1193:       s(3)=sz
 1194:       m = maxnei
 1195:       if(n .le. maxnei) m = n
 1196:       sz8 = m*n
 1197:       n8 = n
 1198: 
 1199:       do i=0,n
 1200:          first(i+1) = i*m + 1
 1201:       enddo
 1202: 
 1203:       if(m .eq. n) then
 1204: !     Compute the full matrix...
 1205:          do i=1,n
 1206:             k = first(i)-1
 1207:             do j=1,n
 1208:                cc(k+j) = permdist(p(3*i-2), q(3*j-2), s, pbc)
 1209:                kk(k+j) = j
 1210: !              write(*,*) i, j, '-->', cc(k+j)
 1211:             enddo
 1212:          enddo
 1213:       else
 1214: !     We need to store the distances of the maxnei closeest neighbors
 1215: !     of each particle. The following builds a heap to keep track of
 1216: !     the maxnei closest neighbours seen so far. It might be more
 1217: !     efficient to use quick-select instead... (This is definitely
 1218: !     true in the limit of infinite systems.)
 1219:         do i=1,n
 1220:            k = first(i)-1
 1221:            do j=1,m
 1222:               cc(k+j) = permdist(p(3*i-2), q(3*j-2), s, pbc)
 1223:               kk(k+j) = j
 1224:               l = j
 1225: 10            if(l .le. 1) goto 11
 1226:               l2 = l/2
 1227:               if(cc(k+l2) .lt. cc(k+l)) then
 1228:                  h = cc(k+l2)
 1229:                  cc(k+l2) = cc(k+l)
 1230:                  cc(k+l) = h
 1231:                  t = kk(k+l2)
 1232:                  kk(k+l2) = kk(k+l)
 1233:                  kk(k+l) = t
 1234:                  l = l2
 1235:                  goto 10
 1236:               endif
 1237: 11         enddo
 1238: 
 1239:            do j=m+1,n
 1240:               d = permdist(p(3*i-2), q(3*j-2), s, pbc)
 1241:               if(d .lt. cc(k+1)) then
 1242:                  cc(k+1) = d
 1243:                  kk(k+1) = j
 1244:                  l = 1
 1245: 20               l2 = 2*l
 1246:                  if(l2+1 .gt. m) goto 21
 1247:                  if(cc(k+l2+1) .gt. cc(k+l2)) then
 1248:                     a = k+l2+1
 1249:                  else
 1250:                     a = k+l2
 1251:                  endif
 1252:                  if(cc(a) .gt. cc(k+l)) then
 1253:                     h = cc(a)
 1254:                     cc(a) = cc(k+l)
 1255:                     cc(k+l) = h
 1256:                     t = kk(a)
 1257:                     kk(a) = kk(k+l)
 1258:                     kk(k+l) = t
 1259:                     l = a-k
 1260:                     goto 20
 1261:                  endif
 1262: 21               if (l2 .le. m) THEN ! split IF statements to avoid a segmentation fault
 1263:                     IF (cc(k+l2) .gt. cc(k+l)) then
 1264:                        h = cc(k+l2)
 1265:                        cc(k+l2) = cc(k+l)
 1266:                        cc(k+l) = h
 1267:                        t = kk(k+l2)
 1268:                        kk(k+l2) = kk(k+l)
 1269:                        kk(k+l) = t
 1270:                     ENDIF
 1271:                  endif
 1272:               endif
 1273:            enddo
 1274:         enddo
 1275:       ENDIF
 1276: 
 1277: END SUBROUTINE PAIRDISTS
 1278: 
956: SUBROUTINE TRANSFORM(NEWCOORDSA, NATOMS, VECTOR, IDNUM)1279: SUBROUTINE TRANSFORM(NEWCOORDSA, NATOMS, VECTOR, IDNUM)
957: 1280: 
958: IMPLICIT NONE1281: IMPLICIT NONE
959: INTEGER, INTENT(IN) :: NATOMS, IDNUM1282: INTEGER, INTENT(IN) :: NATOMS, IDNUM
960: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3)1283: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3)
961: 1284: 
962: DOUBLE PRECISION, INTENT(OUT) :: NEWCOORDSA(3*NATOMS)1285: DOUBLE PRECISION, INTENT(OUT) :: NEWCOORDSA(3*NATOMS)
963: 1286: 
964: INTEGER I1287: INTEGER I
965: 1288: 
966: IF(BULKT) THEN1289: IF(BULKT) THEN
967:     DO I=1,NATOMS1290:     DO I=1,NATOMS
968:         NEWCOORDSA(3*I-2) = SAVECOORDSA(3*I-2,IDNUM) - VECTOR(1)1291:         NEWCOORDSA(3*I-2) = SAVECOORDSA(3*I-2,IDNUM) - VECTOR(1)
969:         NEWCOORDSA(3*I-1) = SAVECOORDSA(3*I-1,IDNUM) - VECTOR(2)1292:         NEWCOORDSA(3*I-1) = SAVECOORDSA(3*I-1,IDNUM) - VECTOR(2)
970:         NEWCOORDSA(3*I  ) = SAVECOORDSA(3*I  ,IDNUM) - VECTOR(3)1293:         NEWCOORDSA(3*I  ) = SAVECOORDSA(3*I  ,IDNUM) - VECTOR(3)
971:     ENDDO1294:     ENDDO
 1295:     ! NEWMINDIST superimposes COMs of coordinates
 1296: !    NEWCOORDSA(3*I-2) = NEWCOORDSA(3*I-2) + &
 1297: ! & BOXLX*NINT((SAVECOORDSB(3*I-2)-NEWCOORDSA(3*I-2))/BOXLX)
 1298: !    NEWCOORDSA(3*I-1) = NEWCOORDSA(3*I-1) + &
 1299: ! & BOXLY*NINT((SAVECOORDSB(3*I-1)-NEWCOORDSA(3*I-1))/BOXLY)
 1300: !    NEWCOORDSA(3*I  ) = NEWCOORDSA(3*I  ) + &
 1301: ! & BOXLZ*NINT((SAVECOORDSB(3*I  )-NEWCOORDSA(3*I  ))/BOXLZ)
972: ELSE1302: ELSE
973:     CALL ANGLEAXIS2MAT(VECTOR, TRMAT)1303:     CALL ANGLEAXIS2MAT(VECTOR, TRMAT)
974:     DO I=1,NATOMS1304:     DO I=1,NATOMS
975:         NEWCOORDSA(3*I-2:3*I) = MATMUL(TRMAT,SAVECOORDSA(3*I-2:3*I,IDNUM))1305:         NEWCOORDSA(3*I-2:3*I) = MATMUL(TRMAT,SAVECOORDSA(3*I-2:3*I,IDNUM))
976:     ENDDO1306:     ENDDO
977: ENDIF1307: ENDIF
978: 1308: 
979: END SUBROUTINE TRANSFORM1309: END SUBROUTINE TRANSFORM
980: 1310: 
981: SUBROUTINE ANGLEAXIS2MAT(VECTOR,RMAT)1311: SUBROUTINE ANGLEAXIS2MAT(VECTOR,RMAT)
1018: 1348: 
1019: TRACE = RMAT(0,0)+RMAT(1,1)+RMAT(2,2)1349: TRACE = RMAT(0,0)+RMAT(1,1)+RMAT(2,2)
1020: THETA = ACOS(0.5D0*TRACE-0.5D0)1350: THETA = ACOS(0.5D0*TRACE-0.5D0)
1021: VECTOR = (/RMAT(2,1)-RMAT(1,2),RMAT(0,2)-RMAT(2,0),RMAT(1,0)-RMAT(0,1)/)1351: VECTOR = (/RMAT(2,1)-RMAT(1,2),RMAT(0,2)-RMAT(2,0),RMAT(1,0)-RMAT(0,1)/)
1022: VECTOR = VECTOR * 0.5D0 * THETA / SIN(THETA)1352: VECTOR = VECTOR * 0.5D0 * THETA / SIN(THETA)
1023: 1353: 
1024: END SUBROUTINE MAT2ANGLEAXIS1354: END SUBROUTINE MAT2ANGLEAXIS
1025: 1355: 
1026: SUBROUTINE REALLOCATEARRAYS(NATOMS, NUMSTRUCTS, BULKT)1356: SUBROUTINE REALLOCATEARRAYS(NATOMS, NUMSTRUCTS, BULKT)
1027: 1357: 
1028: USE COMMONS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP 
1029: IMPLICIT NONE1358: IMPLICIT NONE
1030: 1359: 
1031: INTEGER, INTENT(IN) :: NATOMS, NUMSTRUCTS1360: INTEGER, INTENT(IN) :: NATOMS, NUMSTRUCTS
1032: LOGICAL, INTENT(IN) :: BULKT1361: LOGICAL, INTENT(IN) :: BULKT
1033: 1362: 
1034: 1363: IF(ALLOCATED(PERMCOORDSB))  DEALLOCATE(PERMCOORDSB)
1035: IF((.NOT.ALLOCATED(PERMGROUP)).OR.(.NOT.ALLOCATED(NPERMSIZE))) THEN1364: IF(BULKT) THEN
1036:     WRITE(*,'(A)') 'ERROR - permutation arrays not set, use PERMOPT keyword'1365:     ALLOCATE(PERMCOORDSB(3,9*NATOMS,NPERMGROUP))
1037:     STOP1366: ELSE
1038: ENDIF1367:     ALLOCATE(PERMCOORDSB(3,NATOMS,NPERMGROUP))
1039:  
1040: CALL SETNATOMS(NATOMS) 
1041:  
1042: IF (SIZE(SAVECOORDSA).NE.(3*NATOMS*NUMSTRUCTS)) THEN 
1043:     IF(ALLOCATED(SAVECOORDSB))  DEALLOCATE(SAVECOORDSB,SAVECOORDSA) 
1044:     IF(ALLOCATED(SAVERA)) DEALLOCATE(SAVERA,SAVERB,BESTCOORDSA,BESTRMAT, & 
1045:      & BESTDISP,BESTITERS,BESTPERMS) 
1046:     ALLOCATE(SAVECOORDSB(3*NATOMS),SAVECOORDSA(3*NATOMS,NUMSTRUCTS), & 
1047:      & SAVERB(NATOMS),SAVERA(NATOMS,NUMSTRUCTS),BESTCOORDSA(3*NATOMS,NUMSTRUCTS), & 
1048:      & BESTRMAT(3,3,NUMSTRUCTS),BESTDISP(3,NUMSTRUCTS),BESTITERS(NUMSTRUCTS), & 
1049:      & BESTPERMS(NATOMS,NUMSTRUCTS)) 
1050: END IF 
1051:  
1052: IF (SIZE(PDUMMYA).NE.(3*NATOMS)) THEN 
1053:     IF(ALLOCATED(PDUMMYA)) DEALLOCATE(PDUMMYA,PDUMMYB,DUMMYA,DUMMYB) 
1054:     ALLOCATE(PDUMMYA(3*NATOMS),PDUMMYB(3*NATOMS),DUMMYA(3*NATOMS), & 
1055:      & DUMMYB(3*NATOMS)) 
1056: END IF 
1057:  
1058: IF (SIZE(DUMMYLDISTS).NE.(PMAXNEI*NATOMS*NPERMGROUP)) THEN 
1059:     IF(ALLOCATED(DUMMYDISTS)) DEALLOCATE(DUMMYDISTS, DUMMYIDX) 
1060:     IF(ALLOCATED(DUMMYNEARDISTS)) DEALLOCATE(DUMMYNEARDISTS,DINVIDX,DUMMYNEARIDX, & 
1061:      & DUMMYLDISTS,DUMMYNEARLDISTS, DUMMYLDISTS2,DUMMYDOTDISP,DUMMYDISPS,PDUMMYND) 
1062:     ALLOCATE(DUMMYDISTS(PMAXNEI*NATOMS,NPERMGROUP),DUMMYNEARDISTS(NATOMS), & 
1063:      & PDUMMYND(NATOMS),DUMMYIDX(PMAXNEI*NATOMS,NPERMGROUP),DUMMYNEARIDX(NATOMS), & 
1064:      & DINVIDX(NATOMS*NATOMS,NPERMGROUP),DUMMYLDISTS(PMAXNEI*NATOMS,NPERMGROUP), & 
1065:      & DUMMYNEARLDISTS(NATOMS),DUMMYLDISTS2(PMAXNEI*NATOMS,NPERMGROUP), & 
1066:      & DUMMYDISPS(3,NATOMS*PMAXNEI,NPERMGROUP),DUMMYDOTDISP(4,NATOMS*PMAXNEI,NPERMGROUP)) 
1067: END IF 
1068:  
1069: IF (SIZE(INVPERMGROUP).NE.(NATOMS)) THEN 
1070:     IF(ALLOCATED(NEWPERM)) DEALLOCATE(NEWPERM,LPERM) 
1071:     IF(ALLOCATED(INVPERMGROUP)) DEALLOCATE(INVPERMGROUP, PERMBEST) 
1072:     ALLOCATE(NEWPERM(NATOMS), LPERM(NATOMS), PERMBEST(NATOMS), INVPERMGROUP(NATOMS)) 
1073: END IF1368: END IF
1074: 1369: 
1075: END SUBROUTINE REALLOCATEARRAYS 
1076:  
1077: SUBROUTINE DEALLOCATEBNB() 
1078:  
1079: IMPLICIT NONE 
1080:  
1081: IF(ALLOCATED(SAVECOORDSB))  DEALLOCATE(SAVECOORDSB,SAVECOORDSA)1370: IF(ALLOCATED(SAVECOORDSB))  DEALLOCATE(SAVECOORDSB,SAVECOORDSA)
1082: IF(ALLOCATED(SAVERA)) DEALLOCATE(SAVERA,SAVERB,BESTCOORDSA,BESTRMAT, &1371: IF(ALLOCATED(SAVERA)) DEALLOCATE(SAVERA,SAVERB,BESTCOORDSA,BESTRMAT,BESTITERS)
1083:  & BESTDISP,BESTITERS,BESTPERMS)1372: ALLOCATE(SAVECOORDSB(3*NATOMS),SAVECOORDSA(3*NATOMS,NUMSTRUCTS), &
1084: IF(ALLOCATED(PDUMMYA)) DEALLOCATE(PDUMMYA,PDUMMYB,DUMMYA,DUMMYB)1373:  & SAVERB(NATOMS),SAVERA(NATOMS,NUMSTRUCTS),BESTCOORDSA(3*NATOMS,NUMSTRUCTS), &
1085: IF(ALLOCATED(DUMMYDISTS)) DEALLOCATE(DUMMYDISTS, DUMMYIDX)1374:  & BESTRMAT(3,3,NUMSTRUCTS),BESTITERS(NUMSTRUCTS))
1086: IF(ALLOCATED(DUMMYNEARDISTS)) DEALLOCATE(DUMMYNEARDISTS,DINVIDX,DUMMYNEARIDX, &1375: 
1087:  & DUMMYLDISTS,DUMMYNEARLDISTS, DUMMYLDISTS2,DUMMYDOTDISP,DUMMYDISPS,PDUMMYND)1376: IF(ALLOCATED(PDUMMYA)) DEALLOCATE(PDUMMYA,PDUMMYB,DUMMYA,DUMMYB,NEWPERM,LPERM)
 1377: IF(ALLOCATED(INVPERMGROUP)) DEALLOCATE(INVPERMGROUP)
 1378: ALLOCATE(PDUMMYA(3*NATOMS),PDUMMYB(3*NATOMS),DUMMYA(3*NATOMS), &
 1379:  & DUMMYB(3*NATOMS),NEWPERM(NATOMS),LPERM(NATOMS),INVPERMGROUP(NATOMS))
 1380: 
 1381: IF(ALLOCATED(DUMMYDISTS)) DEALLOCATE(DUMMYDISTS,DUMMYNEARDISTS,PDUMMYND, &
 1382:  & DUMMYDISPS,DUMMYIDX,DINVIDX,DUMMYNEARIDX,DUMMYLDISTS,DUMMYNEARLDISTS, &
 1383:  & DUMMYLDISTS2,DUMMYDOTDISP)
 1384: ALLOCATE(DUMMYDISTS(PMAXNEI*NATOMS,NPERMGROUP),DUMMYNEARDISTS(NATOMS), &
 1385:  & PDUMMYND(NATOMS),DUMMYIDX(PMAXNEI*NATOMS,NPERMGROUP),DUMMYNEARIDX(NATOMS), &
 1386:  & DINVIDX(NATOMS*NATOMS,NPERMGROUP),DUMMYLDISTS(PMAXNEI*NATOMS,NPERMGROUP), &
 1387:  & DUMMYNEARLDISTS(NATOMS),DUMMYLDISTS2(PMAXNEI*NATOMS,NPERMGROUP), &
 1388:  & DUMMYDISPS(3,NATOMS*PMAXNEI,NPERMGROUP),DUMMYDOTDISP(4,NATOMS*PMAXNEI,NPERMGROUP))
1088: 1389: 
1089: END SUBROUTINE DEALLOCATEBNB1390: END SUBROUTINE REALLOCATEARRAYS
1090: 1391: 
1091: SUBROUTINE SETCLUSTER(INVERT)1392: SUBROUTINE SETCLUSTER(INVERT)
1092: 1393: 
 1394: USE COMMONS, ONLY : MYUNIT,NFREEZE,GEOMDIFFTOL,ORBITTOL,FREEZE,PULLT,TWOD,  &
 1395:     &   EFIELDT,AMBERT,QCIAMBERT,AMBER12T,CHRMMT,STOCKT,CSMT,PERMDIST,      &
 1396:     &   LOCALPERMDIST,LPERMDIST,OHCELLT,QCIPERMCHECK,PERMOPT,PERMINVOPT,    &
 1397:     &   NOINVERSION,GTHOMSONT,MKTRAPT,MULLERBROWNT,RIGID,OHCELLT
 1398: 
1093: IMPLICIT NONE1399: IMPLICIT NONE
 1400: 
1094: LOGICAL, INTENT(IN) :: INVERT1401: LOGICAL, INTENT(IN) :: INVERT
1095: 1402: 
1096: MYUNIT = 61403: MYUNIT = 6
 1404: NFREEZE = 0
 1405: GEOMDIFFTOL = 0.5D0
 1406: ORBITTOL = 1.0D-3
 1407: 
 1408: FREEZE = .FALSE.
 1409: PULLT = .FALSE.
 1410: TWOD = .FALSE.
 1411: EFIELDT = .FALSE.
 1412: AMBERT = .FALSE.
 1413: QCIAMBERT = .FALSE.
 1414: AMBER12T = .FALSE.
 1415: CHRMMT = .FALSE.
 1416: STOCKT = .FALSE.
 1417: CSMT = .FALSE.
 1418: PERMDIST = .TRUE.
 1419: LOCALPERMDIST = .FALSE.
 1420: LPERMDIST = .FALSE.
 1421: QCIPERMCHECK = .FALSE.
 1422: PERMOPT = .TRUE.
1097: PERMINVOPT = INVERT1423: PERMINVOPT = INVERT
1098: NOINVERSION = .NOT.INVERT1424: NOINVERSION = .FALSE.
 1425: GTHOMSONT = .FALSE.
 1426: MKTRAPT = .FALSE.
 1427: MULLERBROWNT = .FALSE.
 1428: RIGID = .FALSE.
 1429: OHCELLT = .FALSE.
1099: 1430: 
1100: END SUBROUTINE SETCLUSTER1431: END SUBROUTINE SETCLUSTER
1101: 1432: 
1102: SUBROUTINE SETBULK(INVERT)1433: SUBROUTINE SETBULK(INVERT)
1103: 1434: 
 1435: USE COMMONS, ONLY : MYUNIT,NFREEZE,GEOMDIFFTOL,ORBITTOL,FREEZE,PULLT,TWOD,  &
 1436:     &   EFIELDT,AMBERT,QCIAMBERT,AMBER12T,CHRMMT,STOCKT,CSMT,PERMDIST,      &
 1437:     &   LOCALPERMDIST,LPERMDIST,OHCELLT,QCIPERMCHECK,PERMOPT,PERMINVOPT,    &
 1438:     &   NOINVERSION,GTHOMSONT,MKTRAPT,MULLERBROWNT,RIGID,OHCELLT
 1439: 
1104: IMPLICIT NONE1440: IMPLICIT NONE
 1441: 
1105: LOGICAL, INTENT(IN) :: INVERT1442: LOGICAL, INTENT(IN) :: INVERT
1106: 1443: 
1107: MYUNIT = 61444: MYUNIT = 6
 1445: NFREEZE = 0
 1446: GEOMDIFFTOL = 0.5D0
 1447: ORBITTOL = 1.0D-3
 1448: 
 1449: FREEZE = .FALSE.
 1450: PULLT = .FALSE.
 1451: TWOD = .FALSE.
 1452: EFIELDT = .FALSE.
 1453: AMBERT = .FALSE.
 1454: QCIAMBERT = .FALSE.
 1455: AMBER12T = .FALSE.
 1456: CHRMMT = .FALSE.
 1457: STOCKT = .FALSE.
 1458: CSMT = .FALSE.
 1459: PERMDIST = .FALSE.
 1460: LOCALPERMDIST = .FALSE.
 1461: LPERMDIST = .FALSE.
 1462: QCIPERMCHECK = .FALSE.
 1463: PERMOPT = .FALSE.
1108: PERMINVOPT = .FALSE.1464: PERMINVOPT = .FALSE.
 1465: NOINVERSION = .FALSE.
 1466: GTHOMSONT = .FALSE.
 1467: MKTRAPT = .FALSE.
 1468: MULLERBROWNT = .FALSE.
 1469: RIGID = .FALSE.
1109: OHCELLT = INVERT1470: OHCELLT = INVERT
1110: 1471: 
1111: END SUBROUTINE SETBULK1472: END SUBROUTINE SETBULK
1112: 1473: 
 1474: SUBROUTINE CHECKKEYWORDS()
 1475: 
 1476: USE COMMONS, ONLY : MYUNIT,NFREEZE,GEOMDIFFTOL,ORBITTOL,FREEZE,PULLT,TWOD,  &
 1477:     &   EFIELDT,AMBERT,QCIAMBERT,AMBER12T,CHRMMT,STOCKT,CSMT,PERMDIST,      &
 1478:     &   LOCALPERMDIST,LPERMDIST,OHCELLT,QCIPERMCHECK,PERMOPT,PERMINVOPT,    &
 1479:     &   NOINVERSION,GTHOMSONT,MKTRAPT,MULLERBROWNT,RIGID,OHCELLT
 1480: 
 1481: IMPLICIT NONE
 1482: 
 1483: IF(STOCKT) THEN
 1484:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with STOCK keyword'
 1485:     STOP
 1486: ENDIF
 1487: 
 1488: IF(CSMT) THEN
 1489:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with CSM keyword'
 1490:     STOP
 1491: ENDIF
 1492: 
 1493: IF(PULLT) THEN
 1494:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with PULL keyword'
 1495:     STOP
 1496: ENDIF
 1497: 
 1498: IF(EFIELDT) THEN
 1499:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with EFIELD keyword'
 1500:     STOP
 1501: ENDIF
 1502: 
 1503: IF(RIGID) THEN
 1504:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with RIGID keyword'
 1505:     STOP
 1506: ENDIF
 1507: 
 1508: IF(QCIPERMCHECK) THEN
 1509:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with QCIPERMCHECK keyword'
 1510:     STOP
 1511: ENDIF
 1512: 
 1513: IF(QCIAMBERT) THEN
 1514:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with QCIAMBER keyword'
 1515:     STOP
 1516: ENDIF
 1517: 
 1518: IF(GTHOMSONT) THEN
 1519:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with GTHOMSON keyword'
 1520:     STOP
 1521: ENDIF
 1522: 
 1523: IF(MKTRAPT) THEN
 1524:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with MKTRAP keyword'
 1525:     STOP
 1526: ENDIF
 1527: 
 1528: IF(TWOD) THEN
 1529:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with TWOD keyword'
 1530:     STOP
 1531: ENDIF
 1532: 
 1533: END SUBROUTINE CHECKKEYWORDS
 1534: 
1113: END MODULE1535: END MODULE
 1536: 
 1537: !INCLUDE "bulkmindist.f90"
 1538: !INCLUDE "minpermdist.f90"
 1539: !INCLUDE "newmindist.f90"
 1540: !INCLUDE "minperm.f90"
 1541: !INCLUDE "orient.f90"


r33355/DSOFT.f90 2017-09-28 12:30:14.223907137 +0100 r33354/DSOFT.f90 2017-09-28 12:30:15.803927937 +0100
145: DOUBLE PRECISION, DIMENSION(0:3*BANDWIDTH-1) :: FACTORIALS145: DOUBLE PRECISION, DIMENSION(0:3*BANDWIDTH-1) :: FACTORIALS
146: DOUBLE PRECISION FACTOR, FUDGE, BETA, A, B, C, JM1(2*BANDWIDTH+1), T1,T2,T3,T4146: DOUBLE PRECISION FACTOR, FUDGE, BETA, A, B, C, JM1(2*BANDWIDTH+1), T1,T2,T3,T4
147: INTEGER(KIND=INT64) I,J,M1,M2,IND1,IND2,MAXM147: INTEGER(KIND=INT64) I,J,M1,M2,IND1,IND2,MAXM
148: 148: 
149: FUDGE = PI / 4 / BANDWIDTH149: FUDGE = PI / 4 / BANDWIDTH
150: DO I=1,2*BANDWIDTH150: DO I=1,2*BANDWIDTH
151:     BETA = FUDGE * (2*I-1)151:     BETA = FUDGE * (2*I-1)
152:     COSB(I) = COS(BETA)152:     COSB(I) = COS(BETA)
153:     COSB2(I) = COS(BETA/2)153:     COSB2(I) = COS(BETA/2)
154:     SINB2(I) = SIN(BETA/2)154:     SINB2(I) = SIN(BETA/2)
155:     SINCOSB2(I) = SINB2(I)*COSB2(I)155:     SINCOSB2 = SINB2*COSB2
156:     SINDIVCOSB2(I) = SINB2(I)/COSB2(I)156:     SINDIVCOSB2 = SINB2/COSB2
157: ENDDO 157: ENDDO 
158: 158: 
159: FACTORIALS(0) = 1.D0159: FACTORIALS(0) = 1.D0
160: DO I=1, 3*BANDWIDTH-1160: DO I=1, 3*BANDWIDTH-1
161:     FACTORIALS(I) = I*FACTORIALS(I-1)161:     FACTORIALS(I) = I*FACTORIALS(I-1)
162: ENDDO162: ENDDO
163: 163: 
164: ! Initialise recurrence164: ! Initialise recurrence
165: WIGNERD(:,:,:,:) = 0.D0165: WIGNERD(:,:,:,:) = 0.D0
166: DO M1=-BANDWIDTH-1,BANDWIDTH-1166: DO M1=-BANDWIDTH-1,BANDWIDTH-1
204: 204: 
205: ! Performs discrete SO3 Fourier Analysis for a real input array for a function205: ! Performs discrete SO3 Fourier Analysis for a real input array for a function
206: ! defined on SO(3) returns a complex array of the Fourier Coefficients.206: ! defined on SO(3) returns a complex array of the Fourier Coefficients.
207: 207: 
208: IMPLICIT NONE208: IMPLICIT NONE
209: 209: 
210: INTEGER(KIND=INT64), INTENT(IN) :: BANDWIDTH210: INTEGER(KIND=INT64), INTENT(IN) :: BANDWIDTH
211: DOUBLE PRECISION, INTENT(IN) :: INPUT(2*BANDWIDTH,2*BANDWIDTH,2*BANDWIDTH)211: DOUBLE PRECISION, INTENT(IN) :: INPUT(2*BANDWIDTH,2*BANDWIDTH,2*BANDWIDTH)
212: COMPLEX(KIND=REAL64), INTENT(OUT) :: OUTPUT(BANDWIDTH, 2*BANDWIDTH-1, 2*BANDWIDTH-1)212: COMPLEX(KIND=REAL64), INTENT(OUT) :: OUTPUT(BANDWIDTH, 2*BANDWIDTH-1, 2*BANDWIDTH-1)
213: 213: 
214: ! INCLUDE "fftw3.f90"214: !INCLUDE "fftw3.f90"
215: COMPLEX(KIND=REAL64) IN1D(2*BANDWIDTH), OUT1D(2*BANDWIDTH), TEMP(2*BANDWIDTH, 2*BANDWIDTH, 2*BANDWIDTH)215: COMPLEX(KIND=REAL64) IN1D(2*BANDWIDTH), OUT1D(2*BANDWIDTH), TEMP(2*BANDWIDTH, 2*BANDWIDTH, 2*BANDWIDTH)
216: INTEGER(KIND=INT64) PLAN, K1,K2,K3,M1,M2,I1,I2,IND1,IND2,J,MAXM216: INTEGER(KIND=INT64) PLAN, K1,K2,K3,M1,M2,I1,I2,IND1,IND2,J,MAXM
217: 217: 
218: 218: 
219: CALL SETBANDWIDTH(BANDWIDTH)219: CALL SETBANDWIDTH(BANDWIDTH)
220: 220: 
221: CALL DFFTW_PLAN_DFT_1D(PLAN, (2*BANDWIDTH), IN1D, OUT1D, FFTW_FORWARD, FFTW_ESTIMATE)221: CALL DFFTW_PLAN_DFT_1D(PLAN, (2*BANDWIDTH), IN1D, OUT1D, FFTW_FORWARD, FFTW_ESTIMATE)
222: 222: 
223: ! Do FFT on axis 1223: ! Do FFT on axis 1
224: DO K1=1,2*BANDWIDTH224: DO K1=1,2*BANDWIDTH
225:     DO K2=1,2*BANDWIDTH225:     DO K2=1,2*BANDWIDTH
226:         DO K3=1,2*BANDWIDTH226:         DO K3=1,2*BANDWIDTH
227:             IN1D(K3) = CMPLX(INPUT(K3,K2,K1),0.D0, REAL64)227:             IN1D(K3) = CMPLX(INPUT(K3,K2,K1), 0.D0, REAL64)
228:         ENDDO228:         ENDDO
229:         CALL DFFTW_EXECUTE_(PLAN, IN1D, OUT1D)229:         CALL DFFTW_EXECUTE_(PLAN, IN1D, OUT1D)
230:         DO K3=1,2*BANDWIDTH230:         DO K3=1,2*BANDWIDTH
231:             TEMP(K3,K2,K1) = OUT1D(K3)231:             TEMP(K3,K2,K1) = OUT1D(K3)
232:         ENDDO232:         ENDDO
233:     ENDDO233:     ENDDO
234: ENDDO234: ENDDO
235: 235: 
236: ! Do FFT on axis 3236: ! Do FFT on axis 3
237: DO K1=1,2*BANDWIDTH237: DO K1=1,2*BANDWIDTH
240:             IN1D(K3) = TEMP(K2,K1,K3)240:             IN1D(K3) = TEMP(K2,K1,K3)
241:         ENDDO241:         ENDDO
242:         CALL DFFTW_EXECUTE_(PLAN, IN1D, OUT1D)242:         CALL DFFTW_EXECUTE_(PLAN, IN1D, OUT1D)
243:         DO K3=1,2*BANDWIDTH243:         DO K3=1,2*BANDWIDTH
244:             TEMP(K2,K1,K3) = OUT1D(K3)/(2*BANDWIDTH)**2244:             TEMP(K2,K1,K3) = OUT1D(K3)/(2*BANDWIDTH)**2
245:         ENDDO245:         ENDDO
246:     ENDDO246:     ENDDO
247: ENDDO247: ENDDO
248: 248: 
249: ! Perform Discrete Wigner Transform249: ! Perform Discrete Wigner Transform
250: OUTPUT = CMPLX(0.D0,0.D0,8)250: OUTPUT = CMPLX(0.D0, 0.D0, REAL64)
251: DO M2=-BANDWIDTH-1,BANDWIDTH-1251: DO M2=-BANDWIDTH-1,BANDWIDTH-1
252:     I2 = MODULO(M2, 2*BANDWIDTH) + 1252:     I2 = MODULO(M2, 2*BANDWIDTH) + 1
253:     IND2 = MODULO(M2, 2*BANDWIDTH-1) + 1253:     IND2 = MODULO(M2, 2*BANDWIDTH-1) + 1
254:     DO M1=-BANDWIDTH-1,BANDWIDTH-1254:     DO M1=-BANDWIDTH-1,BANDWIDTH-1
255:         I1 = MODULO(M1, 2*BANDWIDTH) + 1255:         I1 = MODULO(M1, 2*BANDWIDTH) + 1
256:         IND1 = MODULO(M1, 2*BANDWIDTH-1) + 1256:         IND1 = MODULO(M1, 2*BANDWIDTH-1) + 1
257:         MAXM = MAX(ABS(M1),ABS(M2))257:         MAXM = MAX(ABS(M1),ABS(M2))
258:         DO J=MAXM, BANDWIDTH-1258:         DO J=MAXM, BANDWIDTH-1
259:             DO K1=1,2*BANDWIDTH259:             DO K1=1,2*BANDWIDTH
260:                 OUTPUT(J+1,IND1,IND2) = OUTPUT(J+1,IND1,IND2) + WIGNERD(K1,J+1,IND1,IND2)*WEIGHTS(K1)*TEMP(I1,K1,I2)260:                 OUTPUT(J+1,IND1,IND2) = OUTPUT(J+1,IND1,IND2) + WIGNERD(K1,J+1,IND1,IND2)*WEIGHTS(K1)*TEMP(I1,K1,I2)
271: 271: 
272: ! Performs SO3 Fourier Synthesis for a complex input array of Fourier Coefficients272: ! Performs SO3 Fourier Synthesis for a complex input array of Fourier Coefficients
273: ! Generates a complex output array.273: ! Generates a complex output array.
274: 274: 
275: IMPLICIT NONE275: IMPLICIT NONE
276: 276: 
277: INTEGER(KIND=INT64), INTENT(IN) :: BANDWIDTH277: INTEGER(KIND=INT64), INTENT(IN) :: BANDWIDTH
278: COMPLEX(KIND=REAL64), INTENT(IN) :: INPUT(BANDWIDTH, 2*BANDWIDTH-1, 2*BANDWIDTH-1)278: COMPLEX(KIND=REAL64), INTENT(IN) :: INPUT(BANDWIDTH, 2*BANDWIDTH-1, 2*BANDWIDTH-1)
279: COMPLEX(KIND=REAL64), INTENT(OUT) :: OUTPUT(2*BANDWIDTH,2*BANDWIDTH,2*BANDWIDTH)279: COMPLEX(KIND=REAL64), INTENT(OUT) :: OUTPUT(2*BANDWIDTH,2*BANDWIDTH,2*BANDWIDTH)
280: 280: 
281: ! INCLUDE "fftw3.f90"281: !INCLUDE "fftw3.f90"
282: COMPLEX(KIND=REAL64) IN1D(2*BANDWIDTH), OUT1D(2*BANDWIDTH), TEMP(2*BANDWIDTH, 2*BANDWIDTH, 2*BANDWIDTH)282: COMPLEX(KIND=REAL64) IN1D(2*BANDWIDTH), OUT1D(2*BANDWIDTH), TEMP(2*BANDWIDTH, 2*BANDWIDTH, 2*BANDWIDTH)
283: INTEGER(KIND=INT64) PLAN, K1,K2,K3,M1,M2,I1,I2,IND1,IND2,J,MAXM283: INTEGER(KIND=INT64) PLAN, K1,K2,K3,M1,M2,I1,I2,IND1,IND2,J,MAXM
284: 284: 
285: CALL SETBANDWIDTH(BANDWIDTH)285: CALL SETBANDWIDTH(BANDWIDTH)
286: 286: 
287: CALL DFFTW_PLAN_DFT_1D(PLAN, (2*BANDWIDTH), IN1D, OUT1D, FFTW_BACKWARD, FFTW_ESTIMATE)287: CALL DFFTW_PLAN_DFT_1D(PLAN, (2*BANDWIDTH), IN1D, OUT1D, FFTW_BACKWARD, FFTW_ESTIMATE)
288: 288: 
289: ! Discrete inverse Wigner Transform289: ! Discrete inverse Wigner Transform
290: TEMP = CMPLX(0.D0,0.D0,8)290: TEMP = CMPLX(0.D0, 0.D0, REAL64)
291: DO M2=-BANDWIDTH-1,BANDWIDTH-1291: DO M2=-BANDWIDTH-1,BANDWIDTH-1
292:     I2 = MODULO(M2, 2*BANDWIDTH) + 1292:     I2 = MODULO(M2, 2*BANDWIDTH) + 1
293:     IND2 = MODULO(M2, 2*BANDWIDTH-1) + 1293:     IND2 = MODULO(M2, 2*BANDWIDTH-1) + 1
294:     DO M1=-BANDWIDTH-1,BANDWIDTH-1294:     DO M1=-BANDWIDTH-1,BANDWIDTH-1
295:         I1 = MODULO(M1, 2*BANDWIDTH) + 1295:         I1 = MODULO(M1, 2*BANDWIDTH) + 1
296:         IND1 = MODULO(M1, 2*BANDWIDTH-1) + 1296:         IND1 = MODULO(M1, 2*BANDWIDTH-1) + 1
297:         MAXM = MAX(ABS(M1),ABS(M2))297:         MAXM = MAX(ABS(M1),ABS(M2))
298:         DO K1=1,2*BANDWIDTH298:         DO K1=1,2*BANDWIDTH
299:             DO J=MAXM, BANDWIDTH-1299:             DO J=MAXM, BANDWIDTH-1
300:                 TEMP(I1,K1,I2) = TEMP(I1,K1,I2) + WIGNERD(K1,J+1,IND1,IND2)*INPUT(J+1,IND1,IND2)300:                 TEMP(I1,K1,I2) = TEMP(I1,K1,I2) + WIGNERD(K1,J+1,IND1,IND2)*INPUT(J+1,IND1,IND2)


r33355/fastbulk.f90 2017-09-28 12:30:15.131919090 +0100 r33354/fastbulk.f90 2017-09-28 12:30:16.915942576 +0100
 21:  21: 
 22: ! Subroutines: 22: ! Subroutines:
 23:  23: 
 24: !    FOM_ALIGN_BULK(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,KERNELWIDTH,NDISPLACEMENTS,DISTANCE,DIST2) 24: !    FOM_ALIGN_BULK(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,KERNELWIDTH,NDISPLACEMENTS,DISTANCE,DIST2)
 25: !        MAIN ALIGNMENT ALGORITHM ROUTINE 25: !        MAIN ALIGNMENT ALGORITHM ROUTINE
 26: !        if KERNELWIDTH=0 then algorithm automatically determines a suitable KWIDTH 26: !        if KERNELWIDTH=0 then algorithm automatically determines a suitable KWIDTH
 27: !        If want to test Octahedral symmetry, OHCELLT in COMMONS needs to be set to be .TRUE. 27: !        If want to test Octahedral symmetry, OHCELLT in COMMONS needs to be set to be .TRUE.
 28: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated 28: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated
 29:  29: 
 30: !    ALIGN1(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,KWIDTH,DISTANCE,DIST2,NDISPLACEMENTS,NWAVE,NFSPACE) 30: !    ALIGN1(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,KWIDTH,DISTANCE,DIST2,NDISPLACEMENTS,NWAVE,NFSPACE)
 31: !        Called by ALIGN, use if want to set KWIDTH, NWAVE and NFSPACE 31: !        Called by FOM_ALIGN_BULK, use if want to set KWIDTH, NWAVE and NFSPACE
 32: !        If want to test Octahedral symmetry, OHCELLT in COMMONS needs to be set to be .TRUE. 32: !        If want to test Octahedral symmetry, OHCELLT in COMMONS needs to be set to be .TRUE.
 33: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated 33: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated
 34:  34: 
 35: !    ALIGNCOEFFS(COORDSB,COORDSA,NATOMS,DEBUG,FCOEFFS,NFSPACE,BOXLX,BOXLY,BOXLZ,DISTANCE,DIST2,NDISPS) 35: !    ALIGNCOEFFS(COORDSB,COORDSA,NATOMS,DEBUG,FCOEFFS,NFSPACE,BOXLX,BOXLY,BOXLZ,DISTANCE,DIST2,NDISPS)
 36: !        Primary alignment routine, called by ALIGN1, be careful about using this function 36: !        Primary alignment routine, called by ALIGN1, be careful about using this function
 37: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated 37: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated
 38:  38: 
 39: !    SETWAVEK(NWAVE,WAVEK,BOXLX,BOXLY,BOXLZ) 39: !    SETWAVEK(NWAVE,WAVEK,BOXLX,BOXLY,BOXLZ)
 40:  40: 
 41: !    PERIODICFOURIER(NATOMS, NWAVE, NCOEFF, COORDS, WAVEK, FCOEFF) 41: !    PERIODICFOURIER(NATOMS, NWAVE, NCOEFF, COORDS, WAVEK, FCOEFF)
 44: !    PERIODICFOURIERPERM(COORDS,NATOMS,NWAVE,NCOEFF,WAVEK,FCOEFF,NPERMGROUP) 44: !    PERIODICFOURIERPERM(COORDS,NATOMS,NWAVE,NCOEFF,WAVEK,FCOEFF,NPERMGROUP)
 45: !        Calculates Fourier Coefficients of COORDS using the permutation information 45: !        Calculates Fourier Coefficients of COORDS using the permutation information
 46: !        set by COMMONS 46: !        set by COMMONS
 47:  47: 
 48: !    CALCFSPACE(NATOMS,COORDSA,COORDSB,NWAVE,WAVEK,KWIDTH,NFSPACE,FSPACE) 48: !    CALCFSPACE(NATOMS,COORDSA,COORDSB,NWAVE,WAVEK,KWIDTH,NFSPACE,FSPACE)
 49: !        Calculates overlap integral array 49: !        Calculates overlap integral array
 50:  50: 
 51: !    FINDDISPS(NATOMS,COORDSA,COORDSB,NWAVE,WAVEK,KWIDTH,NFSPACE,DISPS,NDISPS,DEBUG) 51: !    FINDDISPS(NATOMS,COORDSA,COORDSB,NWAVE,WAVEK,KWIDTH,NFSPACE,DISPS,NDISPS,DEBUG)
 52: !        Calculates maximum overlap displacements 52: !        Calculates maximum overlap displacements
 53:  53: 
  54: !    SETBULK()
  55: !        Used to set keywords if they're not set already
  56: 
 54: !    CHECKKEYWORDS() 57: !    CHECKKEYWORDS()
 55: !        Sanity checks for the keywords 58: !        Sanity checks for the keywords
 56:  59: 
 57: !    ALIGN2(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,TWOD,DISTANCE,DIST2,RIGID,DISPBEST,NDISPS,BESTPERM,DISP) 60: !    ALIGN2(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,TWOD,DISTANCE,DIST2,RIGID,DISPBEST,NDISPS,BESTPERM,DISP)
 58: !        Uses MEDIANMINPERMDIST to perform alignment 61: !        Uses MEDIANMINPERMDIST to perform alignment
 59: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated 62: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated
 60:  63: 
 61: !    MEDIANMINPERMDIST(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,DISTANCE,DIST2,DISPBEST,DISP) 64: !    MEDIANMINPERMDIST(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,DISTANCE,DIST2,DISPBEST,DISP)
 62: !        Performs intial alignment by subtracting median displacements. 65: !        Performs intial alignment by subtracting median displacements.
 63:  66: 
 66:  69: 
 67: !    GETDISPLACEMENT(DISP,NATOMS,COORDSB,COORDSA,PERMLIST,BOX) 70: !    GETDISPLACEMENT(DISP,NATOMS,COORDSB,COORDSA,PERMLIST,BOX)
 68: !        Calculates smallest displacement between each atom in two structures 71: !        Calculates smallest displacement between each atom in two structures
 69:  72: 
 70: !    SUBROUTINE OHTRANSFORMCOEFFS(FCOEFF, FCOEFFDUMMY, NWAVE, NF2, NPERMGROUP, OPNUM) 73: !    SUBROUTINE OHTRANSFORMCOEFFS(FCOEFF, FCOEFFDUMMY, NWAVE, NF2, NPERMGROUP, OPNUM)
 71: !        Applies octahedral transformation (specified by OHOPSMAT) to a 3D 74: !        Applies octahedral transformation (specified by OHOPSMAT) to a 3D
 72: !        array of Fourier Coefficients of a structure. 75: !        array of Fourier Coefficients of a structure.
 73:  76: 
 74: !*********************************************************************** 77: !***********************************************************************
 75:  78: 
  79: ! EXTERNAL SUBROUTINES
  80: !    MINPERMDIST (minpermdist.f90) depends on (bulkmindist.f90,minperm.f90,newmindist.f90,orient.f90)
  81: !    PERMDIST
  82: !    OHOPS (bulkmindist.f90)
  83: 
  84: !***********************************************************************
  85: 
 76: ! EXTERNAL MODULES 86: ! EXTERNAL MODULES
 77: !    COMMONS (commons.f90) 87: !    COMMONS (commons.f90)
 78: !        Module used mostly for compatibility with GMIN and OPTIM 88: !        Module used mostly for compatibility with GMIN and OPTIM
 79: !        and subroutines copied from GMIN 89: !        and subroutines copied from GMIN
 80: !    ALIGNUTILS depends on LAPACK 90: 
 81: !        Module for alignment routines, including a reduced version of MINPERMDIST 91: !    FASTOVERLAPUTILS (fastutils.f90) depends on (minperm.f90)
 82: !    FASTOVERLAPUTILS (fastutils.f90) 
 83: !        Helper Module Needed for Peak Fitting and FFT routines 92: !        Helper Module Needed for Peak Fitting and FFT routines
 84:  93: 
 85: !*********************************************************************** 94: !***********************************************************************
 86:  95: 
 87: !INCLUDE "commons.f90" 
 88: !INCLUDE "alignutils.f90" 
 89: !INCLUDE "fastutils.f90" 
 90:  
 91: MODULE BULKFASTOVERLAP 96: MODULE BULKFASTOVERLAP
 92:  97: 
 93: USE ALIGNUTILS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP, NATOMS, MYUNIT, NSETS, SETS, & 98: USE COMMONS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP, NATOMS, MYUNIT, NSETS, SETS, &
 94:  & BOXLX, BOXLY, BOXLZ, OHCELLT, TWOD, SAVECOORDS, NSTORED 99:  & BOXLX, BOXLY, BOXLZ
 95: USE FASTOVERLAPUTILS, ONLY : DUMMYA, DUMMYB, XBESTA, XBESTASAVE100: USE FASTOVERLAPUTILS, ONLY : DUMMYA, DUMMYB, XBESTA, XBESTASAVE
 96: USE PREC, ONLY: INT64, REAL64101: USE PREC, ONLY: REAL64
 97: 102: 
 98: IMPLICIT NONE103: IMPLICIT NONE
 99: 104: 
100: ! If this is set to a value other than zero, algorithm will use this value105: ! If this is set to a value other than zero, algorithm will use this value
101: ! else it will set KWIDTH = 1/3 average interatomic separation.106: ! else it will set KWIDTH = 1/3 average interatomic separation.
102: DOUBLE PRECISION, SAVE :: KWIDTH=0.D0107: DOUBLE PRECISION, SAVE :: KWIDTH=0.D0
 108: LOGICAL, SAVE :: OHCELLTSAVE
103: DOUBLE PRECISION, SAVE :: OHOPSMAT(3,3,48)109: DOUBLE PRECISION, SAVE :: OHOPSMAT(3,3,48)
104: 110: 
105: DATA OHOPSMAT / &111: DATA OHOPSMAT / &
106:  & 1.00000000000D0,  0.0D0,  0.0D0,   &112:  & 1.00000000000D0,  0.0D0,  0.0D0,   &
107:  & 0.0D0,  1.00000000000D0,  0.0D0,   &113:  & 0.0D0,  1.00000000000D0,  0.0D0,   &
108:  & 0.0D0,  0.0D0,  1.00000000000D0,   &114:  & 0.0D0,  0.0D0,  1.00000000000D0,   &
109:  & -1.00000000000D0,  0.0D0,  0.0D0,   &115:  & -1.00000000000D0,  0.0D0,  0.0D0,   &
110:  & 0.0D0,  -1.00000000000D0,  0.0D0,   &116:  & 0.0D0,  -1.00000000000D0,  0.0D0,   &
111:  & 0.0D0,  0.0D0,  1.00000000000D0,   &117:  & 0.0D0,  0.0D0,  1.00000000000D0,   &
112:  & 0.0D0,  0.0D0,  1.00000000000D0,   &118:  & 0.0D0,  0.0D0,  1.00000000000D0,   &
244:  & 0.0D0,  1.00000000000D0,  0.0D0,   &250:  & 0.0D0,  1.00000000000D0,  0.0D0,   &
245:  & 1.00000000000D0,  0.0D0,  0.0D0,   &251:  & 1.00000000000D0,  0.0D0,  0.0D0,   &
246:  & 0.0D0,  0.0D0,  1.00000000000D0,   &252:  & 0.0D0,  0.0D0,  1.00000000000D0,   &
247:  & 0.0D0,  -1.00000000000D0,  0.0D0,   &253:  & 0.0D0,  -1.00000000000D0,  0.0D0,   &
248:  & -1.00000000000D0,  0.0D0,  0.0D0,   &254:  & -1.00000000000D0,  0.0D0,  0.0D0,   &
249:  & 0.0D0,  0.0D0,  1.00000000000D0 /255:  & 0.0D0,  0.0D0,  1.00000000000D0 /
250: 256: 
251: 257: 
252: CONTAINS258: CONTAINS
253: 259: 
254: SUBROUTINE CALCDEFAULTS(NCOORDS,BOXLX,BOXLY,BOXLZ,KERNELWIDTH,NWAVE,NFSPACE)260: SUBROUTINE CALCDEFAULTS(NATOMS,BOXLX,BOXLY,BOXLZ,KERNELWIDTH,NWAVE,NFSPACE)
255: 261: 
256: USE FASTOVERLAPUTILS, ONLY: FASTLEN262: USE FASTOVERLAPUTILS, ONLY: FASTLEN
257: 263: 
258: IMPLICIT NONE264: IMPLICIT NONE
259: INTEGER, INTENT(IN) :: NCOORDS265: INTEGER, INTENT(IN) :: NATOMS
260: DOUBLE PRECISION, INTENT(IN) :: BOXLX,BOXLY,BOXLZ266: DOUBLE PRECISION, INTENT(IN) :: BOXLX,BOXLY,BOXLZ
261: DOUBLE PRECISION, INTENT(OUT) :: KERNELWIDTH267: DOUBLE PRECISION, INTENT(OUT) :: KERNELWIDTH
262: INTEGER, INTENT(OUT) :: NWAVE,NFSPACE268: INTEGER, INTENT(OUT) :: NWAVE,NFSPACE
263: 269: 
264: DOUBLE PRECISION MAXWAVEK270: DOUBLE PRECISION MAXWAVEK
265: 271: 
266: NATOMS=NCOORDS 
267: KERNELWIDTH = (BOXLX*BOXLY*BOXLZ/NATOMS)**(1.D0/3.D0) / 3.D0272: KERNELWIDTH = (BOXLX*BOXLY*BOXLZ/NATOMS)**(1.D0/3.D0) / 3.D0
268: MAXWAVEK = 1.5 / KERNELWIDTH273: MAXWAVEK = 1.5 / KERNELWIDTH
269: NWAVE = CEILING(2*3.14159265359/MIN(BOXLX,BOXLY,BOXLZ)*MAXWAVEK, 4)274: NWAVE = CEILING(2*3.14159265359/MIN(BOXLX,BOXLY,BOXLZ)*MAXWAVEK, 4)
270: 275: 
271: 276: 
272: IF((2*NWAVE+1).LE.200) THEN277: IF((2*NWAVE+1).LE.200) THEN
273:     NFSPACE = FASTLEN(4*NWAVE+3)278:     NFSPACE = FASTLEN(4*NWAVE+3)
274: ELSE279: ELSE
275:     ! PROBABLY NOT THE BEST WAY TO CALCULATE THIS!280:     ! PROBABLY NOT THE BEST WAY TO CALCULATE THIS!
276:     NFSPACE = 2**CEILING(LOG(4.D0*NWAVE+3.D0)/LOG(2.D0),4)281:     NFSPACE = 2**CEILING(LOG(4.D0*NWAVE+3.D0)/LOG(2.D0),4)
277: ENDIF282: ENDIF
278: 283: 
279: END SUBROUTINE CALCDEFAULTS284: END SUBROUTINE CALCDEFAULTS
280: 285: 
281: SUBROUTINE FOM_ALIGN_BULK(COORDSB,COORDSA,NCOORDS,DEBUG,NBOXLX,NBOXLY,NBOXLZ,KERNELWIDTH,NDISPLACEMENTS,DISTANCE,DIST2)286: SUBROUTINE FOM_ALIGN_BULK(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,KERNELWIDTH,NDISPLACEMENTS,DISTANCE,DIST2)
282: ! COORDSA becomes the optimal alignment of the optimal permutation of COORDSB287: ! COORDSA becomes the optimal alignment of the optimal permutation of COORDSB
283: 288: 
284: USE FASTOVERLAPUTILS, ONLY: FASTLEN, SETNATOMS289: USE FASTOVERLAPUTILS, ONLY: FASTLEN, SETNATOMS
285: IMPLICIT NONE290: IMPLICIT NONE
286: 291: 
287: INTEGER, INTENT(IN) :: NCOORDS, NDISPLACEMENTS292: INTEGER, INTENT(IN) :: NATOMS, NDISPLACEMENTS
288: LOGICAL, INTENT(IN) :: DEBUG293: LOGICAL, INTENT(IN) :: DEBUG
289: DOUBLE PRECISION, INTENT(IN) :: NBOXLX, NBOXLY, NBOXLZ, KERNELWIDTH294: DOUBLE PRECISION, INTENT(IN) :: BOXLX, BOXLY, BOXLZ, KERNELWIDTH
290: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS)295: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NATOMS), COORDSB(3*NATOMS)
291: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2296: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2
292: 297: 
 298: 
293: DOUBLE PRECISION KWIDTH, MAXWAVEK299: DOUBLE PRECISION KWIDTH, MAXWAVEK
294: INTEGER NWAVE, NFSPACE, NDISPS300: INTEGER NWAVE, NFSPACE, NDISPS
295: 301: 
296: NATOMS = NCOORDS 
297: BOXLX=NBOXLX; BOXLY=NBOXLY; BOXLZ=NBOXLZ 
298: CALL CHECKKEYWORDS() 
299: CALL SETNATOMS(NATOMS)302: CALL SETNATOMS(NATOMS)
300: 303: 
301:  
302: ! Set KWIDTH to be 1/3 of the average interatomic separation304: ! Set KWIDTH to be 1/3 of the average interatomic separation
303: IF (KERNELWIDTH.LE.0.D0) THEN305: IF (KERNELWIDTH.LE.0.D0) THEN
304:     KWIDTH = (BOXLX*BOXLY*BOXLZ/NATOMS)**(1.D0/3.D0) / 3.D0306:     KWIDTH = (BOXLX*BOXLY*BOXLZ/NATOMS)**(1.D0/3.D0) / 3.D0
305:     IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> kernel distance automatically set to ', KWIDTH307:     IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> kernel distance automatically set to ', KWIDTH
306: ELSE308: ELSE
307:     KWIDTH = KERNELWIDTH309:     KWIDTH = KERNELWIDTH
308:     IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> kernel distance set to ', KWIDTH310:     IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> kernel distance set to ', KWIDTH
309: ENDIF311: ENDIF
310: 312: 
311: ! Calculate number of wavevectors that we need to preserve reasonable level of accuracy313: ! Calculate number of wavevectors that we need to preserve reasonable level of accuracy
324: IF (DEBUG) WRITE(MYUNIT,'(A,I4)') 'fastoverlap> overlap array resolution set to ', NFSPACE326: IF (DEBUG) WRITE(MYUNIT,'(A,I4)') 'fastoverlap> overlap array resolution set to ', NFSPACE
325: 327: 
326: 328: 
327: IF(NDISPLACEMENTS.EQ.0) THEN329: IF(NDISPLACEMENTS.EQ.0) THEN
328:     NDISPS = 10330:     NDISPS = 10
329: ELSE331: ELSE
330:     NDISPS = NDISPLACEMENTS332:     NDISPS = NDISPLACEMENTS
331: END IF333: END IF
332: IF (DEBUG) WRITE(MYUNIT,'(A,I3)') 'fastoverlap> number of displacements to be tested = ', NDISPS334: IF (DEBUG) WRITE(MYUNIT,'(A,I3)') 'fastoverlap> number of displacements to be tested = ', NDISPS
333: 335: 
334: !WRITE(*,*) "DEBUG,BOXLX,BOXLY,BOXLZ,KWIDTH,DISTANCE,DIST2,NDISPLACEMENTS,NWAVE,NFSPACE" 
335: !WRITE(*,*) DEBUG,BOXLX,BOXLY,BOXLZ,KWIDTH,DISTANCE,DIST2,NDISPS,NWAVE,NFSPACE 
336: CALL ALIGN1(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,KWIDTH,DISTANCE,DIST2,NDISPS,NWAVE,NFSPACE)336: CALL ALIGN1(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,KWIDTH,DISTANCE,DIST2,NDISPS,NWAVE,NFSPACE)
337: 337: 
338: END SUBROUTINE FOM_ALIGN_BULK338: END SUBROUTINE FOM_ALIGN_BULK
339: 339: 
340: SUBROUTINE ALIGNGROUP(COORDS1LIST,N1LIST,COORDS2LIST,N2LIST,NCOORDS,DEBUG, &340: SUBROUTINE ALIGNGROUP(COORDS1LIST,N1LIST,COORDS2LIST,N2LIST,NATOMS,DEBUG, &
341:     & NBOXLX,NBOXLY,NBOXLZ,KWIDTH,NDISPLACEMENTS,NWAVE,NFSPACE,DISTMAT,ALIGNEDCOORDS2,SYM)341:     & BOXLX,BOXLY,BOXLZ,KWIDTH,NDISPLACEMENTS,NWAVE,NFSPACE,DISTMAT,ALIGNEDCOORDS2,SYM)
342:  
343: USE FASTOVERLAPUTILS, ONLY: SETNATOMS 
344: 342: 
345: IMPLICIT NONE343: IMPLICIT NONE
346: INTEGER, INTENT(IN) :: N1LIST, N2LIST, NCOORDS, NDISPLACEMENTS, NFSPACE, NWAVE344: INTEGER, INTENT(IN) :: N1LIST, N2LIST, NATOMS, NDISPLACEMENTS, NFSPACE, NWAVE
347: LOGICAL, INTENT(IN) :: DEBUG,SYM345: LOGICAL, INTENT(IN) :: DEBUG,SYM
348: DOUBLE PRECISION, INTENT(IN) :: NBOXLX, NBOXLY, NBOXLZ, KWIDTH346: DOUBLE PRECISION, INTENT(IN) :: BOXLX, BOXLY, BOXLZ, KWIDTH
349: DOUBLE PRECISION, INTENT(INOUT) :: COORDS1LIST(3*NCOORDS,N1LIST), COORDS2LIST(3*NCOORDS,N2LIST)347: DOUBLE PRECISION, INTENT(INOUT) :: COORDS1LIST(3*NATOMS,N1LIST), COORDS2LIST(3*NATOMS,N2LIST)
350: DOUBLE PRECISION, INTENT(OUT) :: DISTMAT(N1LIST,N2LIST), ALIGNEDCOORDS2(3*NCOORDS,N1LIST,N2LIST)348: DOUBLE PRECISION, INTENT(OUT) :: DISTMAT(N1LIST,N2LIST), ALIGNEDCOORDS2(3*NATOMS,N1LIST,N2LIST)
351: 349: 
352: COMPLEX(KIND=REAL64) FCOEFF1(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP,N1LIST), &350: COMPLEX(KIND=REAL64) FCOEFF1(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP,N1LIST), &
353:     & FCOEFF2(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP,N2LIST), FCOEFFS(NFSPACE,NFSPACE,NFSPACE)351:     & FCOEFF2(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP,N2LIST), FCOEFFS(NFSPACE,NFSPACE,NFSPACE)
354: DOUBLE PRECISION WAVEK(3, 2*NWAVE+1,2*NWAVE+1,2*NWAVE+1), K2(2*NWAVE+1,2*NWAVE+1,2*NWAVE+1), DIST2352: DOUBLE PRECISION WAVEK(3, 2*NWAVE+1,2*NWAVE+1,2*NWAVE+1), K2(2*NWAVE+1,2*NWAVE+1,2*NWAVE+1), DIST2
355: INTEGER I,J,K,JX,JY,JZ,NDISPS353: INTEGER I,J,K,JX,JY,JZ,NDISPS
356: 354: 
357: IF (DEBUG) WRITE(MYUNIT,'(A)') 'fastoverlap> starting group alignment'355: IF (DEBUG) WRITE(MYUNIT,'(A)') 'fastoverlap> starting group alignment'
358: IF (DEBUG) WRITE(MYUNIT,'(A,I5,A,I5)') 'fastoverlap> aligning ', N1LIST, ' structures with ', N2LIST356: IF (DEBUG) WRITE(MYUNIT,'(A,I5,A,I5)') 'fastoverlap> aligning ', N1LIST, ' structures with ', N2LIST
359: 357: 
360: SAVECOORDS = .FALSE. !Don't save coordinates when doing group alignment 
361: NATOMS = NCOORDS 
362: BOXLX=NBOXLX; BOXLY=NBOXLY; BOXLZ=NBOXLZ 
363: CALL SETNATOMS(NATOMS) 
364:  
365: CALL SETWAVEK(NWAVE,WAVEK,BOXLX,BOXLY,BOXLZ)358: CALL SETWAVEK(NWAVE,WAVEK,BOXLX,BOXLY,BOXLZ)
366: DO JZ=1,2*NWAVE+1359: DO JZ=1,2*NWAVE+1
367:     DO JY=1,2*NWAVE+1360:     DO JY=1,2*NWAVE+1
368:         DO JX=1,2*NWAVE+1361:         DO JX=1,2*NWAVE+1
369:             K2(JX,JY,JZ) = EXP(-0.5D0 * (WAVEK(1,JX,JY,JZ)**2 + WAVEK(2,JX,JY,JZ)**2 + WAVEK(3,JX,JY,JZ)**2)*KWIDTH**2)362:             K2(JX,JY,JZ) = EXP(-0.5D0 * (WAVEK(1,JX,JY,JZ)**2 + WAVEK(2,JX,JY,JZ)**2 + WAVEK(3,JX,JY,JZ)**2)*KWIDTH**2)
370:         ENDDO363:         ENDDO
371:     ENDDO364:     ENDDO
372: ENDDO365: ENDDO
373: 366: 
374: DO J=1,N1LIST367: DO J=1,N1LIST
410:             ALIGNEDCOORDS2(:,I,J) = COORDS2LIST(:,J)403:             ALIGNEDCOORDS2(:,I,J) = COORDS2LIST(:,J)
411:             NDISPS = NDISPLACEMENTS404:             NDISPS = NDISPLACEMENTS
412:             CALL ALIGNCOEFFS(COORDS1LIST(:,I),ALIGNEDCOORDS2(:,I,J),NATOMS,DEBUG,FCOEFFS,NFSPACE, &405:             CALL ALIGNCOEFFS(COORDS1LIST(:,I),ALIGNEDCOORDS2(:,I,J),NATOMS,DEBUG,FCOEFFS,NFSPACE, &
413:                 & BOXLX,BOXLY,BOXLZ,DISTMAT(I,J),DIST2,NDISPS)406:                 & BOXLX,BOXLY,BOXLZ,DISTMAT(I,J),DIST2,NDISPS)
414:         ENDDO407:         ENDDO
415:     ENDDO408:     ENDDO
416: ENDIF409: ENDIF
417: 410: 
418: END SUBROUTINE ALIGNGROUP411: END SUBROUTINE ALIGNGROUP
419: 412: 
420: SUBROUTINE ALIGN1(COORDSB,COORDSA,NCOORDS,DEBUG,NBOXLX,NBOXLY,NBOXLZ,KWIDTH,DISTANCE,DIST2,NDISPLACEMENTS,NWAVE,NFSPACE)413: SUBROUTINE ALIGN1(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,KWIDTH,DISTANCE,DIST2,NDISPLACEMENTS,NWAVE,NFSPACE)
421: 414: 
422: USE ALIGNUTILS, ONLY: OHOPS, PRINTDISTANCES415: USE COMMONS, ONLY: OHCELLT
423: USE FASTOVERLAPUTILS, ONLY : SETNATOMS 
424: 416: 
425: IMPLICIT NONE417: IMPLICIT NONE
426: 418: 
427: INTEGER, INTENT(IN) :: NCOORDS, NDISPLACEMENTS, NFSPACE, NWAVE419: INTEGER, INTENT(IN) :: NATOMS, NDISPLACEMENTS, NFSPACE, NWAVE
428: LOGICAL, INTENT(IN) :: DEBUG420: LOGICAL, INTENT(IN) :: DEBUG
429: DOUBLE PRECISION, INTENT(IN) :: NBOXLX, NBOXLY, NBOXLZ, KWIDTH421: DOUBLE PRECISION, INTENT(IN) :: BOXLX, BOXLY, BOXLZ, KWIDTH
430: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS)422: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NATOMS), COORDSB(3*NATOMS)
431: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2423: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2
432: 424: 
433: DOUBLE PRECISION WAVEK(3, 2*NWAVE+1,2*NWAVE+1,2*NWAVE+1), K2, DISTSAVE425: DOUBLE PRECISION WAVEK(3, 2*NWAVE+1,2*NWAVE+1,2*NWAVE+1), K2, DISTSAVE
434: DOUBLE PRECISION SAVEA(3*NCOORDS), SAVEB(3*NCOORDS)426: DOUBLE PRECISION SAVEA(3*NATOMS), SAVEB(3*NATOMS)
435: COMPLEX(KIND=REAL64) FCOEFFS(NFSPACE,NFSPACE,NFSPACE), FCOEFFA(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP), &427: COMPLEX(KIND=REAL64) FCOEFFS(NFSPACE,NFSPACE,NFSPACE), FCOEFFA(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP), &
436:  & FCOEFFB(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP), FCOEFFDUMMYA(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP)428:  & FCOEFFB(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP), FCOEFFDUMMYA(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP)
437: INTEGER J, JX, JY, JZ, OPNUM, NDISPS, JXL, JYL, JZL, JXH, JYH, JZH, JXI, JYI, JZI429: INTEGER J, JX, JY, JZ, OPNUM, NDISPS, JXL, JYL, JZL, JXH, JYH, JZH, JXI, JYI, JZI
438: 430: 
439: NSTORED=0431: CALL CHECKKEYWORDS()
440: NATOMS=NCOORDS432: OHCELLTSAVE = OHCELLT
441: BOXLX=NBOXLX; BOXLY=NBOXLY; BOXLZ=NBOXLZ433: OHCELLT = .FALSE.
442: CALL SETNATOMS(NATOMS) 
443: 434: 
444: ! Calculating Fourier Coefficients of COORDSA and COORDSB435: ! Calculating Fourier Coefficients of COORDSA and COORDSB
445: CALL SETWAVEK(NWAVE,WAVEK,BOXLX,BOXLY,BOXLZ)436: CALL SETWAVEK(NWAVE,WAVEK,BOXLX,BOXLY,BOXLZ)
446: CALL PERIODICFOURIERPERM(COORDSA,NATOMS,NWAVE,NFSPACE,WAVEK,FCOEFFA,NPERMGROUP)437: CALL PERIODICFOURIERPERM(COORDSA,NATOMS,NWAVE,NFSPACE,WAVEK,FCOEFFA,NPERMGROUP)
447: CALL PERIODICFOURIERPERM(COORDSB,NATOMS,NWAVE,NFSPACE,WAVEK,FCOEFFB,NPERMGROUP)438: CALL PERIODICFOURIERPERM(COORDSB,NATOMS,NWAVE,NFSPACE,WAVEK,FCOEFFB,NPERMGROUP)
448: 439: 
 440: !FCOEFFS = CMPLX(0.D0, 0.D0, REAL64)
449: FCOEFFA = CONJG(FCOEFFA)441: FCOEFFA = CONJG(FCOEFFA)
450: 442: 
451: ! Calculating Fourier Coefficients of overlap integral443: ! Calculating Fourier Coefficients of overlap integral
452: DO JZ=1,2*NWAVE+1444: DO JZ=1,2*NWAVE+1
453:     DO JY=1,2*NWAVE+1445:     DO JY=1,2*NWAVE+1
454:         DO JX=1,2*NWAVE+1446:         DO JX=1,2*NWAVE+1
455:             K2 = EXP(-0.5D0 * (WAVEK(1,JX,JY,JZ)**2 + WAVEK(2,JX,JY,JZ)**2 + WAVEK(3,JX,JY,JZ)**2)*KWIDTH**2)447:             K2 = EXP(-0.5D0 * (WAVEK(1,JX,JY,JZ)**2 + WAVEK(2,JX,JY,JZ)**2 + WAVEK(3,JX,JY,JZ)**2)*KWIDTH**2)
456:             FCOEFFA(JX,JY,JZ,:) = FCOEFFA(JX,JY,JZ,:) * K2448:             FCOEFFA(JX,JY,JZ,:) = FCOEFFA(JX,JY,JZ,:) * K2
457:             FCOEFFB(JX,JY,JZ,:) = FCOEFFB(JX,JY,JZ,:) * K2449:             FCOEFFB(JX,JY,JZ,:) = FCOEFFB(JX,JY,JZ,:) * K2
 450:             !FCOEFFS(JX,JY,JZ) = SUM(FCOEFFA(JX,JY,JZ,:)*FCOEFFB(JX,JY,JZ,:))
458:         ENDDO451:         ENDDO
459:     ENDDO452:     ENDDO
460: ENDDO453: ENDDO
461: 454: 
462: CALL DOTFOURIERCOEFFS(FCOEFFB,FCOEFFA,NWAVE,NFSPACE,FCOEFFS,NPERMGROUP)455: CALL DOTFOURIERCOEFFS(FCOEFFB,FCOEFFA,NWAVE,NFSPACE,FCOEFFS,NPERMGROUP)
463: 456: 
 457: !Set average overlap to 0
 458: !FCOEFFS(NWAVE+1,NWAVE+1,NWAVE+1)=(0.D0,0.D0)
 459: 
464: SAVEB(1:3*NATOMS) = COORDSB(1:3*NATOMS)460: SAVEB(1:3*NATOMS) = COORDSB(1:3*NATOMS)
465: 461: 
466: IF (OHCELLT) THEN462: IF (OHCELLTSAVE) THEN
467:     DISTSAVE = HUGE(DISTSAVE)463:     DISTSAVE = HUGE(DISTSAVE)
468:     DO OPNUM=1,48464:     DO OPNUM=1,48
469:         IF (DEBUG) WRITE(MYUNIT,'(A,I2)') 'fastoverlap> Trying Oh symmetry operation number ',OPNUM465:         IF (DEBUG) WRITE(MYUNIT,'(A,I2)') 'fastoverlap> Trying Oh symmetry operation number ',OPNUM
470:         CALL OHOPS(COORDSA,SAVEA,OPNUM,NATOMS)466:         CALL OHOPS(COORDSA,SAVEA,OPNUM,NATOMS)
471:         ! Applying octahedral symmetry operation to FCOEFFA467:         ! Applying octahedral symmetry operation to FCOEFFA
472:         CALL OHTRANSFORMCOEFFS(FCOEFFA, FCOEFFDUMMYA, NWAVE, NFSPACE-NWAVE-1, NPERMGROUP, OPNUM)468:         CALL OHTRANSFORMCOEFFS(FCOEFFA, FCOEFFDUMMYA, NWAVE, NFSPACE-NWAVE-1, NPERMGROUP, OPNUM)
473: 469: 
 470:         ! Recalculating Fourier Coefficients
 471: !        FCOEFFS = CMPLX(0.D0, 0.D0, REAL64)
 472: !        DO J=1,NPERMGROUP
 473: !            DO JZ=1,2*NWAVE+1
 474: !                DO JY=1,2*NWAVE+1
 475: !                    DO JX=1,2*NWAVE+1
 476: !                        FCOEFFS(JX,JY,JZ) = FCOEFFS(JX,JY,JZ) + &
 477: !                        & FCOEFFDUMMYA(JX,JY,JZ,J)*FCOEFFB(JX,JY,JZ,J)
 478: !                    ENDDO
 479: !                ENDDO
 480: !            ENDDO
 481: !        ENDDO
474:         CALL DOTFOURIERCOEFFS(FCOEFFB,FCOEFFA,NWAVE,NFSPACE,FCOEFFS,NPERMGROUP)482:         CALL DOTFOURIERCOEFFS(FCOEFFB,FCOEFFA,NWAVE,NFSPACE,FCOEFFS,NPERMGROUP)
 483:         !FCOEFFS(NWAVE+1,NWAVE+1,NWAVE+1)=(0.D0,0.D0)
475: 484: 
476:         NDISPS = NDISPLACEMENTS485:         NDISPS = NDISPLACEMENTS
477:         CALL ALIGNCOEFFS(SAVEB,SAVEA,NATOMS,DEBUG,FCOEFFS,NFSPACE,BOXLX,BOXLY,BOXLZ,DISTANCE,DIST2,NDISPS)486:         CALL ALIGNCOEFFS(SAVEB,SAVEA,NATOMS,DEBUG,FCOEFFS,NFSPACE,BOXLX,BOXLY,BOXLZ,DISTANCE,DIST2,NDISPS)
478: 487: 
479:         IF (DISTANCE.LT.DISTSAVE) THEN488:         IF (DISTANCE.LT.DISTSAVE) THEN
480:             IF (DEBUG) WRITE(MYUNIT,'(A,I2,A,G20.10)') &489:             IF (DEBUG) WRITE(MYUNIT,'(A,I2,A,G20.10)') &
481:  & 'fastoverlap> Oh symmetry operation ', OPNUM, ' found better alignment, distance=', distance490:  & 'fastoverlap> Oh symmetry operation ', OPNUM, ' found better alignment, distance=', distance
482:             XBESTASAVE(1:3*NATOMS) = SAVEA(1:3*NATOMS)491:             XBESTASAVE(1:3*NATOMS) = SAVEA(1:3*NATOMS)
483:             DISTSAVE = DISTANCE492:             DISTSAVE = DISTANCE
484:         ELSE493:         ELSE
491:     IF (DEBUG) WRITE(MYUNIT,'(A)') 'fastoverlap> not testing Oh symmetry'500:     IF (DEBUG) WRITE(MYUNIT,'(A)') 'fastoverlap> not testing Oh symmetry'
492: 501: 
493:     XBESTASAVE(1:3*NATOMS) = COORDSA(1:3*NATOMS)502:     XBESTASAVE(1:3*NATOMS) = COORDSA(1:3*NATOMS)
494:     NDISPS = NDISPLACEMENTS503:     NDISPS = NDISPLACEMENTS
495:     CALL ALIGNCOEFFS(SAVEB,XBESTASAVE,NATOMS,DEBUG,FCOEFFS,NFSPACE,BOXLX,BOXLY,BOXLZ,DISTSAVE,DIST2,NDISPS)504:     CALL ALIGNCOEFFS(SAVEB,XBESTASAVE,NATOMS,DEBUG,FCOEFFS,NFSPACE,BOXLX,BOXLY,BOXLZ,DISTSAVE,DIST2,NDISPS)
496: 505: 
497:     IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') &506:     IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') &
498:  & 'fastoverlap> overall best alignment distance=', distsave507:  & 'fastoverlap> overall best alignment distance=', distsave
499: ENDIF508: ENDIF
500: 509: 
501: IF(DEBUG.AND.SAVECOORDS) CALL PRINTDISTANCES() 
502: 510: 
503: DISTANCE = DISTSAVE511: DISTANCE = DISTSAVE
504: DIST2 = DISTANCE**2512: DIST2 = DISTANCE**2
505: COORDSA(1:3*NATOMS) = XBESTASAVE(1:3*NATOMS)513: COORDSA(1:3*NATOMS) = XBESTASAVE(1:3*NATOMS)
506: 514: 
 515: OHCELLT = OHCELLTSAVE
 516: 
507: END SUBROUTINE ALIGN1517: END SUBROUTINE ALIGN1
508: 518: 
509: SUBROUTINE ALIGNCOEFFS(COORDSB,COORDSA,NCOORDS,DEBUG,FCOEFFS,NFSPACE,LX,LY,LZ,DISTANCE,DIST2,NDISPS)519: SUBROUTINE ALIGNCOEFFS(COORDSB,COORDSA,NATOMS,DEBUG,FCOEFFS,NFSPACE,LX,LY,LZ,DISTANCE,DIST2,NDISPS)
510: 520: 
511: USE FASTOVERLAPUTILS, ONLY : FFT3D, FINDPEAKS521: USE FASTOVERLAPUTILS, ONLY : FFT3D, FINDPEAKS
512: USE ALIGNUTILS, ONLY : ITERATIVEALIGN 
513: IMPLICIT NONE522: IMPLICIT NONE
514: 523: 
515: INTEGER, INTENT(INOUT) :: NDISPS524: INTEGER, INTENT(INOUT) :: NDISPS
516: INTEGER, INTENT(IN) :: NCOORDS, NFSPACE525: INTEGER, INTENT(IN) :: NATOMS, NFSPACE
517: LOGICAL, INTENT(IN) :: DEBUG526: LOGICAL, INTENT(IN) :: DEBUG
518: COMPLEX(KIND=REAL64), INTENT(IN) ::  FCOEFFS(NFSPACE,NFSPACE,NFSPACE)527: COMPLEX(KIND=REAL64), INTENT(IN) ::  FCOEFFS(NFSPACE,NFSPACE,NFSPACE)
519: DOUBLE PRECISION, INTENT(IN) :: LX, LY, LZ528: DOUBLE PRECISION, INTENT(IN) :: LX, LY, LZ
520: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS)529: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NATOMS), COORDSB(3*NATOMS)
521: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2530: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2
522: 531: 
523: COMPLEX(KIND=REAL64) FSPACECMPLX(NFSPACE,NFSPACE,NFSPACE)532: COMPLEX(KIND=REAL64) FSPACECMPLX(NFSPACE,NFSPACE,NFSPACE)
524: DOUBLE PRECISION FSPACE(NFSPACE,NFSPACE,NFSPACE), DISPS(NDISPS,3), R(3,3), BESTDIST533: DOUBLE PRECISION FSPACE(NFSPACE,NFSPACE,NFSPACE), DISPS(NDISPS,3), R(3,3), BESTDIST
525: DOUBLE PRECISION AMPLITUDES(NDISPS), DISP(3)534: DOUBLE PRECISION AMPLITUDES(NDISPS)
526: INTEGER J, J1, PERMBEST(NCOORDS)535: INTEGER J, J1
527: 536: 
528: NATOMS=NCOORDS 
529: BOXLX = LX; BOXLY = LY; BOXLZ = LZ537: BOXLX = LX; BOXLY = LY; BOXLZ = LZ
530: 538: 
531: CALL FFT3D(NFSPACE,NFSPACE,NFSPACE,FCOEFFS,FSPACECMPLX)539: CALL FFT3D(NFSPACE,NFSPACE,NFSPACE,FCOEFFS,FSPACECMPLX)
532: FSPACE = ABS(FSPACECMPLX)540: FSPACE = ABS(FSPACECMPLX)
533: 541: 
534: CALL FINDPEAKS(FSPACE, DISPS, AMPLITUDES, NDISPS, DEBUG)542: CALL FINDPEAKS(FSPACE, DISPS, AMPLITUDES, NDISPS, DEBUG)
535: IF (DEBUG) WRITE(MYUNIT,'(A,I3,A)') 'fastoverlap> found ', NDISPS, ' candidate displacements'543: IF (DEBUG) WRITE(MYUNIT,'(A,I3,A)') 'fastoverlap> found ', NDISPS, ' candidate displacements'
536: 544: 
537: DISPS = DISPS - 1.D0545: DISPS = DISPS - 1.D0
538: DISPS(:,1) = DISPS(:,1)*BOXLX/NFSPACE546: DISPS(:,1) = DISPS(:,1)*BOXLX/NFSPACE
539: DISPS(:,2) = DISPS(:,2)*BOXLY/NFSPACE547: DISPS(:,2) = DISPS(:,2)*BOXLY/NFSPACE
540: DISPS(:,3) = DISPS(:,3)*BOXLZ/NFSPACE548: DISPS(:,3) = DISPS(:,3)*BOXLZ/NFSPACE
541: 549: 
542: BESTDIST = HUGE(BESTDIST)550: BESTDIST = HUGE(BESTDIST)
543: DUMMYB(1:3*NATOMS) = COORDSB(1:3*NATOMS)551: DUMMYB(1:3*NATOMS) = COORDSB(1:3*NATOMS)
544: DO J=1,NDISPS552: DO J=1,NDISPS
545:  
546:     IF (TWOD) DISPS(J,3) = 0.D0 
547:     IF (DEBUG.AND.TWOD) WRITE(MYUNIT,'(A)') 'fastoverlap> twod alignment, setting z displacement to 0' 
548:  
549:     DO J1=1,NATOMS553:     DO J1=1,NATOMS
550:         DUMMYA(J1*3-2:J1*3) = COORDSA(J1*3-2:J1*3) - DISPS(J,:)554:         DUMMYA(J1*3-2:J1*3) = COORDSA(J1*3-2:J1*3) - DISPS(J,:)
551:     ENDDO555:     ENDDO
552: 556: 
553:     IF (DEBUG) WRITE(MYUNIT,'(A,I3)') 'fastoverlap> testing displacement', J557:     IF (DEBUG) WRITE(MYUNIT,'(A,I3)') 'fastoverlap> testing displacement', J
554:     IF (DEBUG) WRITE(MYUNIT,'(3G20.10)') DISPS(J,:)558:     IF (DEBUG) WRITE(MYUNIT,'(3G20.10)') DISPS(J,:)
555: 559: 
556:     CALL ITERATIVEALIGN(DUMMYB,DUMMYA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,.TRUE.,DIST2,DISTANCE,R,DISP,PERMBEST)560:     CALL MINPERMDIST(DUMMYB,DUMMYA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,.TRUE.,.FALSE.,DISTANCE,DIST2,.FALSE.,R)
557: 561: 
558:     IF (DISTANCE.LT.BESTDIST) THEN562:     IF (DISTANCE.LT.BESTDIST) THEN
559:         BESTDIST = DISTANCE563:         BESTDIST = DISTANCE
560:         IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> found new best alignment distance=', BESTDIST564:         IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> found new best alignment distance=', BESTDIST
561:         XBESTA(1:3*NATOMS) = DUMMYA(1:3*NATOMS)565:         XBESTA(1:3*NATOMS) = DUMMYA(1:3*NATOMS)
562:     ELSE566:     ELSE
563:         IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> best aligment distance found=', BESTDIST567:         IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> best aligment distance found=', BESTDIST
564:     ENDIF568:     ENDIF
565: ENDDO569: ENDDO
566: 570: 
567: IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> FINAL best aligment distance found=', BESTDIST571: IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> FINAL best aligment distance found=', BESTDIST
568: 572: 
569: 573: 
570: COORDSA(1:3*NATOMS) = XBESTA(1:3*NATOMS)574: COORDSA(1:3*NATOMS) = XBESTA(1:3*NATOMS)
571: DISTANCE = BESTDIST575: DISTANCE = BESTDIST
572: DIST2 = BESTDIST**2576: DIST2 = BESTDIST**2
573: 577: 
574: END SUBROUTINE ALIGNCOEFFS578: END SUBROUTINE ALIGNCOEFFS
575: 579: 
576: SUBROUTINE SETWAVEK(NWAVE,WAVEK,NBOXLX,NBOXLY,NBOXLZ)580: SUBROUTINE SETWAVEK(NWAVE,WAVEK,BOXLX,BOXLY,BOXLZ)
577: 581: 
578: ! NWAVE: number of wavevectors >0 in any axis582: ! NWAVE: number of wavevectors >0 in any axis
579: ! COORDS: coordinate vector583: ! COORDS: coordinate vector
580: ! WAVEK: wavevectors584: ! WAVEK: wavevectors
581: ! FCOEFF: fourier coefficients of coordinates585: ! FCOEFF: fourier coefficients of coordinates
582: 586: 
583: IMPLICIT NONE587: IMPLICIT NONE
584: INTEGER, INTENT(IN) :: NWAVE588: INTEGER, INTENT(IN) :: NWAVE
585: DOUBLE PRECISION, INTENT(IN) :: NBOXLX,NBOXLY,NBOXLZ589: DOUBLE PRECISION, INTENT(IN) :: BOXLX,BOXLY,BOXLZ
586: DOUBLE PRECISION, INTENT(OUT) :: WAVEK(3,2*NWAVE+1,2*NWAVE+1,2*NWAVE+1)590: DOUBLE PRECISION, INTENT(OUT) :: WAVEK(3,2*NWAVE+1,2*NWAVE+1,2*NWAVE+1)
587: 591: 
588: INTEGER IX,IY,IZ592: INTEGER IX,IY,IZ
589: DOUBLE PRECISION, PARAMETER :: TWOPI = 6.283185307179586D0593: DOUBLE PRECISION, PARAMETER :: TWOPI = 6.283185307179586D0
590: DOUBLE PRECISION KX, KY, KZ594: DOUBLE PRECISION KX, KY, KZ
591: 595: 
592: BOXLX=NBOXLX; BOXLY=NBOXLY; BOXLZ=NBOXLZ 
593: KX = TWOPI / BOXLX596: KX = TWOPI / BOXLX
594: KY = TWOPI / BOXLY597: KY = TWOPI / BOXLY
595: KZ = TWOPI / BOXLZ598: KZ = TWOPI / BOXLZ
596: 599: 
597: DO IX=1,2*NWAVE+1600: DO IX=1,2*NWAVE+1
598:     DO IY=1,2*NWAVE+1601:     DO IY=1,2*NWAVE+1
599:         DO IZ=1,2*NWAVE+1602:         DO IZ=1,2*NWAVE+1
600:             WAVEK(1,IX,IY,IZ) = KX*(IX-NWAVE-1)603:             WAVEK(1,IX,IY,IZ) = KX*(IX-NWAVE-1)
601:             WAVEK(2,IX,IY,IZ) = KY*(IY-NWAVE-1)604:             WAVEK(2,IX,IY,IZ) = KY*(IY-NWAVE-1)
602:             WAVEK(3,IX,IY,IZ) = KZ*(IZ-NWAVE-1)605:             WAVEK(3,IX,IY,IZ) = KZ*(IZ-NWAVE-1)
603:         ENDDO606:         ENDDO
604:     ENDDO607:     ENDDO
605: ENDDO608: ENDDO
606: 609: 
607: END SUBROUTINE SETWAVEK610: END SUBROUTINE SETWAVEK
608: 611: 
609: SUBROUTINE PERIODICFOURIER(NCOORDS, NWAVE, NCOEFF, COORDS, WAVEK, FCOEFF)612: SUBROUTINE PERIODICFOURIER(NATOMS, NWAVE, NCOEFF, COORDS, WAVEK, FCOEFF)
610: ! Calculates fourier coefficients of a set of coordinates613: ! Calculates fourier coefficients of a set of coordinates
611: 614: 
612: ! NATOMS: system size615: ! NATOMS: system size
613: ! NWAVE: number of wavevectors modes, FCOEFF will have (2*NWAVE+1)^3 elements616: ! NWAVE: number of wavevectors modes, FCOEFF will have (2*NWAVE+1)^3 elements
614: ! COORDS: coordinate vector617: ! COORDS: coordinate vector
615: ! WAVEK: wavevectors618: ! WAVEK: wavevectors
616: ! FCOEFF: fourier coefficients of coordinates619: ! FCOEFF: fourier coefficients of coordinates
617: 620: 
618: IMPLICIT NONE621: IMPLICIT NONE
619: 622: 
620: INTEGER, INTENT(IN) :: NCOORDS, NWAVE, NCOEFF623: INTEGER, INTENT(IN) :: NATOMS, NWAVE, NCOEFF
621: DOUBLE PRECISION, INTENT(IN) :: COORDS(3*NCOORDS), WAVEK(3,2*NWAVE+1,2*NWAVE+1,2*NWAVE+1)624: DOUBLE PRECISION, INTENT(IN) :: COORDS(3*NATOMS), WAVEK(3,2*NWAVE+1,2*NWAVE+1,2*NWAVE+1)
622: !COMPLEX(KIND=REAL64), INTENT(OUT) :: FCOEFF(NCOEFF,NCOEFF,NCOEFF)625: COMPLEX(KIND=REAL64), INTENT(OUT) :: FCOEFF(NCOEFF,NCOEFF,NCOEFF)
623: COMPLEX(REAL64), INTENT(OUT) :: FCOEFF(NCOEFF,NCOEFF,NCOEFF) 
624: 626: 
625: INTEGER IX,IY,IZ, J, K627: INTEGER IX,IY,IZ, J, K
626: DOUBLE PRECISION KR628: DOUBLE PRECISION :: KR
627: 629: 
628: NATOMS=NCOORDS630: !FCOEFF = CMPLX(0.d0, 0.d0, REAL64)
629: FCOEFF = CMPLX(0.d0,0.d0,REAL64)631: FCOEFF = CMPLX(0.0D0, 0.0D0, REAL64)
630: DO IX=1,2*NWAVE+1632: DO IX=1,2*NWAVE+1
631:     DO IY=1,2*NWAVE+1633:     DO IY=1,2*NWAVE+1
632:         DO IZ=1,2*NWAVE+1634:         DO IZ=1,2*NWAVE+1
633: !            FCOEFF(IX,IY,IZ) = CMPLX(0.d0,0.d0)635: !            FCOEFF(IX,IY,IZ) = CMPLX(0.d0, 0.d0, REAL64)
634:             DO J=1, NATOMS636:             DO J=1, NATOMS
635:                 KR=0.d0637:                 KR=0.d0
636:                 DO K=1,3638:                 DO K=1,3
637:                     KR = KR + COORDS(3*J-3+K) * WAVEK(K,IX,IY,IZ)639:                     KR = KR + COORDS(3*J-3+K) * WAVEK(K,IX,IY,IZ)
638:                 ENDDO640:                 ENDDO
639:                 FCOEFF(IX,IY,IZ) = FCOEFF(IX,IY,IZ) + EXP(CMPLX(0.d0, -KR, REAL64))641:                 FCOEFF(IX,IY,IZ) = FCOEFF(IX,IY,IZ) + EXP(CMPLX(0.0D0, -KR, REAL64))
640:             ENDDO642:             ENDDO
641:         ENDDO643:         ENDDO
642:     ENDDO644:     ENDDO
643: ENDDO645: ENDDO
644: 646: 
645: END SUBROUTINE PERIODICFOURIER647: END SUBROUTINE PERIODICFOURIER
646: 648: 
647: SUBROUTINE PERIODICFOURIERPERM(COORDS,NCOORDS,NWAVE,NCOEFF,WAVEK,FCOEFF,NPERMGROUPS)!,PERMGROUP,NPERMSIZE,NPERMGROUP)649: SUBROUTINE PERIODICFOURIERPERM(COORDS,NATOMS,NWAVE,NCOEFF,WAVEK,FCOEFF,NPERMGROUP)!,PERMGROUP,NPERMSIZE,NPERMGROUP)
648: ! Calculates Fourier coefficients of the different permutations of a structure.650: ! Calculates Fourier coefficients of the different permutations of a structure.
649: 651: 
650: IMPLICIT NONE652: IMPLICIT NONE
651: 653: 
652: INTEGER, INTENT(IN) :: NPERMGROUPS654: INTEGER, INTENT(IN) :: NPERMGROUP
653: INTEGER, INTENT(IN) :: NCOORDS, NWAVE, NCOEFF655: INTEGER, INTENT(IN) :: NATOMS, NWAVE, NCOEFF
654: !INTEGER, INTENT(IN) :: PERMGROUP(NCOORDS), NPERMSIZE(NPERMGROUP)656: !INTEGER, INTENT(IN) :: PERMGROUP(NATOMS), NPERMSIZE(NPERMGROUP)
655: DOUBLE PRECISION, INTENT(IN) :: COORDS(NCOORDS*3),  WAVEK(3,2*NWAVE+1,2*NWAVE+1,2*NWAVE+1)657: DOUBLE PRECISION, INTENT(IN) :: COORDS(NATOMS*3),  WAVEK(3,2*NWAVE+1,2*NWAVE+1,2*NWAVE+1)
656: !DOUBLE PRECISION, INTENT(IN) :: BOXLX,BOXLY,BOXLZ658: !DOUBLE PRECISION, INTENT(IN) :: BOXLX,BOXLY,BOXLZ
657: COMPLEX(KIND=REAL64), INTENT(OUT) :: FCOEFF(NCOEFF,NCOEFF,NCOEFF,NPERMGROUPS)659: COMPLEX(KIND=REAL64), INTENT(OUT) :: FCOEFF(NCOEFF,NCOEFF,NCOEFF,NPERMGROUP)
658: 660: 
659: COMPLEX(KIND=REAL64) FCOEFFDUMMY(NCOEFF,NCOEFF,NCOEFF)661: COMPLEX(KIND=REAL64) FCOEFFDUMMY(NCOEFF,NCOEFF,NCOEFF)
660: DOUBLE PRECISION PDUMMY(3*NCOORDS)662: DOUBLE PRECISION PDUMMY(3*NATOMS)
661: INTEGER NDUMMY, J1, J2, PATOMS663: INTEGER NDUMMY, J1, J2, PATOMS
662: 664: 
663: IF (NPERMGROUP.NE.NPERMGROUPS) THEN 
664:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
665:     STOP 
666: ENDIF 
667:  
668: NDUMMY=1665: NDUMMY=1
669: 666: 
670: DO J1=1,NPERMGROUP667: DO J1=1,NPERMGROUP
671:     PATOMS=NPERMSIZE(J1)668:     PATOMS=NPERMSIZE(J1)
672:     DO J2=1,PATOMS669:     DO J2=1,PATOMS
673:         PDUMMY(3*(J2-1)+1)=COORDS(3*(PERMGROUP(NDUMMY+J2-1)-1)+1)670:         PDUMMY(3*(J2-1)+1)=COORDS(3*(PERMGROUP(NDUMMY+J2-1)-1)+1)
674:         PDUMMY(3*(J2-1)+2)=COORDS(3*(PERMGROUP(NDUMMY+J2-1)-1)+2)671:         PDUMMY(3*(J2-1)+2)=COORDS(3*(PERMGROUP(NDUMMY+J2-1)-1)+2)
675:         PDUMMY(3*(J2-1)+3)=COORDS(3*(PERMGROUP(NDUMMY+J2-1)-1)+3)672:         PDUMMY(3*(J2-1)+3)=COORDS(3*(PERMGROUP(NDUMMY+J2-1)-1)+3)
676:     ENDDO673:     ENDDO
677:     CALL PERIODICFOURIER(PATOMS, NWAVE, NCOEFF, PDUMMY, WAVEK, FCOEFFDUMMY)674:     CALL PERIODICFOURIER(PATOMS, NWAVE, NCOEFF, PDUMMY, WAVEK, FCOEFFDUMMY)
684: SUBROUTINE DOTFOURIERCOEFFS(FCOEFFB,FCOEFFA,NWAVE,NCOEFF,FCOEFFS,NPERMGROUP)681: SUBROUTINE DOTFOURIERCOEFFS(FCOEFFB,FCOEFFA,NWAVE,NCOEFF,FCOEFFS,NPERMGROUP)
685: 682: 
686: IMPLICIT NONE683: IMPLICIT NONE
687: 684: 
688: INTEGER, INTENT(IN) :: NPERMGROUP, NWAVE, NCOEFF685: INTEGER, INTENT(IN) :: NPERMGROUP, NWAVE, NCOEFF
689: COMPLEX(KIND=REAL64), INTENT(IN) :: FCOEFFA(NCOEFF,NCOEFF,NCOEFF,NPERMGROUP),FCOEFFB(NCOEFF,NCOEFF,NCOEFF,NPERMGROUP)686: COMPLEX(KIND=REAL64), INTENT(IN) :: FCOEFFA(NCOEFF,NCOEFF,NCOEFF,NPERMGROUP),FCOEFFB(NCOEFF,NCOEFF,NCOEFF,NPERMGROUP)
690: COMPLEX(KIND=REAL64), INTENT(OUT) :: FCOEFFS(NCOEFF,NCOEFF,NCOEFF)687: COMPLEX(KIND=REAL64), INTENT(OUT) :: FCOEFFS(NCOEFF,NCOEFF,NCOEFF)
691: 688: 
692: INTEGER J689: INTEGER J
693: 690: 
694: FCOEFFS = CMPLX(0.D0,0.D0,REAL64)691: FCOEFFS = CMPLX(0.D0, 0.D0, REAL64)
695: 692: 
696: DO J=1,NPERMGROUP693: DO J=1,NPERMGROUP
697:     FCOEFFS = FCOEFFS + FCOEFFA(:,:,:,J)*FCOEFFB(:,:,:,J)694:     FCOEFFS = FCOEFFS + FCOEFFA(:,:,:,J)*FCOEFFB(:,:,:,J)
698: END DO695: END DO
699: 696: 
700: END SUBROUTINE DOTFOURIERCOEFFS697: END SUBROUTINE DOTFOURIERCOEFFS
701: 698: 
702: !SUBROUTINE CALCFSPACE(NCOORDS,COORDSA,COORDSB,NWAVE,WAVEK,KWIDTH,NFSPACE,FSPACE)!,NPERMGROUP)699: SUBROUTINE CALCFSPACE(NATOMS,COORDSA,COORDSB,NWAVE,WAVEK,KWIDTH,NFSPACE,FSPACE)!,NPERMGROUP)
703: !!700: !
704: !! Calculate FASTOVERLAP real space array701: ! Calculate FASTOVERLAP real space array
705: !! Given two bulk structures calculates the value of the overlap integral as702: ! Given two bulk structures calculates the value of the overlap integral as
706: !! FSPACE(NFSPACE, NFSPACE, NFSPACE). It does this by performing an FFT of the703: ! FSPACE(NFSPACE, NFSPACE, NFSPACE). It does this by performing an FFT of the
707: !! product Fourier coefficients of both structures.704: ! product Fourier coefficients of both structures.
708: !!705: !
709: !USE FASTOVERLAPUTILS, ONLY: FFT3D706: USE FASTOVERLAPUTILS, ONLY: FFT3D
710: 707: 
711: !IMPLICIT NONE708: IMPLICIT NONE
712:  
713: !INTEGER, INTENT(IN) :: NCOORDS, NWAVE, NFSPACE!, NPERMGROUP 
714: !DOUBLE PRECISION, INTENT(IN) :: KWIDTH 
715: !DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS) 
716: !DOUBLE PRECISION, INTENT(IN) :: WAVEK(3, 2*NWAVE+1,2*NWAVE+1,2*NWAVE+1) 
717:  
718: !DOUBLE PRECISION, INTENT(OUT) :: FSPACE(NFSPACE, NFSPACE, NFSPACE) 
719:  
720: !COMPLEX(KIND=REAL64) FCOEFFA(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP), FCOEFFB(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP), COEFF 
721: !COMPLEX(KIND=REAL64) FCOEFF(NFSPACE,NFSPACE,NFSPACE) 
722: !COMPLEX(KIND=REAL64) FSPACECMPLX(NFSPACE,NFSPACE,NFSPACE) 
723:  
724: !INTEGER I, JX, JY, JZ 
725: !DOUBLE PRECISION K2 
726:  
727: !CALL PERIODICFOURIERPERM(COORDSA,NCOORDS,NWAVE,NFSPACE,WAVEK,FCOEFFA,NPERMGROUP)!,PERMGROUP,NPERMSIZE,NPERMGROUP) 
728: !CALL PERIODICFOURIERPERM(COORDSB,NCOORDS,NWAVE,NFSPACE,WAVEK,FCOEFFB,NPERMGROUP)!,PERMGROUP,NPERMSIZE,NPERMGROUP) 
729:  
730: !FCOEFF = DCMPLX(0.D0, 0.D0) 
731: !FCOEFFB = CONJG(FCOEFFB) 
732:  
733: !DO JX=1,2*NWAVE+1 
734: !    DO JY=1,2*NWAVE+1 
735: !        DO JZ=1,2*NWAVE+1 
736: !            COEFF = DCMPLX(0.D0, 0.D0) 
737: !            K2 = -(WAVEK(1,JX,JY,JZ)**2 + WAVEK(2,JX,JY,JZ)**2 + WAVEK(3,JX,JY,JZ)**2)*KWIDTH**2 
738: !            COEFF = SUM(FCOEFFA(JX,JY,JZ,:)*FCOEFFB(JX,JY,JZ,:))*EXP(K2) 
739: !            FCOEFF(JX,JY,JZ) = COEFF 
740: !        ENDDO 
741: !    ENDDO 
742: !ENDDO 
743: 709: 
744: !!Set average overlap to 0710: INTEGER, INTENT(IN) :: NATOMS, NWAVE, NFSPACE!, NPERMGROUP
745: !FCOEFF(NWAVE+1,NWAVE+1,NWAVE+1)=(0.d0,0.d0)711: DOUBLE PRECISION, INTENT(IN) :: KWIDTH
 712: DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NATOMS), COORDSB(3*NATOMS)
 713: DOUBLE PRECISION, INTENT(IN) :: WAVEK(3, 2*NWAVE+1,2*NWAVE+1,2*NWAVE+1)
746: 714: 
747: !CALL FFT3D(NFSPACE,NFSPACE,NFSPACE,FCOEFF,FSPACECMPLX)715: DOUBLE PRECISION, INTENT(OUT) :: FSPACE(NFSPACE, NFSPACE, NFSPACE)
748: 716: 
749: !FSPACE = ABS(FSPACECMPLX)717: COMPLEX(KIND=REAL64) FCOEFFA(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP), FCOEFFB(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP), COEFF
750: 718: COMPLEX(KIND=REAL64) FCOEFF(NFSPACE,NFSPACE,NFSPACE)
751: !END SUBROUTINE CALCFSPACE719: COMPLEX(KIND=REAL64) FSPACECMPLX(NFSPACE,NFSPACE,NFSPACE)
752:  
753: !SUBROUTINE FINDDISPS(NCOORDS,COORDSA,COORDSB,NWAVE,WAVEK,KWIDTH,NFSPACE,DISPS,NDISPS,DEBUG) 
754: !! 
755: !! Performs FASTOVERLAP alignment for periodic 3D structures 
756: !! 
757: !! Calculates up to NDISPS possible displacements to align coordinates COORDSA and COORDSB 
758: !! Outputs DISPS as fractional coordinates, so DISPS must be multiplied by the lattice vector 
759: !! to obtain the full displacements 
760: !! 
761: !USE FASTOVERLAPUTILS, ONLY: FINDPEAKS 
762: !IMPLICIT NONE 
763: !INTEGER, INTENT(IN) :: NCOORDS, NWAVE, NFSPACE 
764: !INTEGER, INTENT(INOUT) :: NDISPS 
765: !LOGICAL, INTENT(IN) :: DEBUG 
766: !DOUBLE PRECISION, INTENT(IN) :: KWIDTH, COORDSA(3*NCOORDS), COORDSB(3*NCOORDS), WAVEK(3, 2*NWAVE+1,2*NWAVE+1,2*NWAVE+1) 
767: !DOUBLE PRECISION, INTENT(OUT) :: DISPS(NDISPS,3) 
768:  
769: !INTEGER J 
770: !DOUBLE PRECISION FSPACE(NFSPACE, NFSPACE, NFSPACE), AMPLITUDES(NDISPS) 
771:  
772: !CALL CALCFSPACE(NCOORDS,COORDSA,COORDSB,NWAVE,WAVEK,KWIDTH,NFSPACE,FSPACE)!,NPERMGROUP) 
773:  
774: !CALL FINDPEAKS(FSPACE, DISPS, AMPLITUDES, NDISPS, DEBUG) 
775:  
776: !DISPS = DISPS - 1.D0 
777: !DO J=1,NDISPS 
778: !    DISPS(J,:) = DISPS(J,:)/(/NFSPACE,NFSPACE,NFSPACE/) 
779: !ENDDO 
780: 720: 
781: !END SUBROUTINE FINDDISPS721: INTEGER I, JX, JY, JZ
 722: DOUBLE PRECISION K2
782: 723: 
783: SUBROUTINE CHECKKEYWORDS()724: CALL PERIODICFOURIERPERM(COORDSA,NATOMS,NWAVE,NFSPACE,WAVEK,FCOEFFA,NPERMGROUP)!,PERMGROUP,NPERMSIZE,NPERMGROUP)
 725: CALL PERIODICFOURIERPERM(COORDSB,NATOMS,NWAVE,NFSPACE,WAVEK,FCOEFFB,NPERMGROUP)!,PERMGROUP,NPERMSIZE,NPERMGROUP)
 726: 
 727: FCOEFF = CMPLX(0.D0, 0.D0, REAL64)
 728: FCOEFFB = CONJG(FCOEFFB)
 729: 
 730: DO JX=1,2*NWAVE+1
 731:     DO JY=1,2*NWAVE+1
 732:         DO JZ=1,2*NWAVE+1
 733:             COEFF = CMPLX(0.D0, 0.D0, REAL64)
 734:             K2 = -(WAVEK(1,JX,JY,JZ)**2 + WAVEK(2,JX,JY,JZ)**2 + WAVEK(3,JX,JY,JZ)**2)*KWIDTH**2
 735:             COEFF = SUM(FCOEFFA(JX,JY,JZ,:)*FCOEFFB(JX,JY,JZ,:))*EXP(K2)
 736:             FCOEFF(JX,JY,JZ) = COEFF
 737:         ENDDO
 738:     ENDDO
 739: ENDDO
 740: 
 741: !Set average overlap to 0
 742: FCOEFF(NWAVE+1,NWAVE+1,NWAVE+1)=(0.d0,0.d0)
 743: 
 744: CALL FFT3D(NFSPACE,NFSPACE,NFSPACE,FCOEFF,FSPACECMPLX)
 745: 
 746: FSPACE = ABS(FSPACECMPLX)
 747: 
 748: END SUBROUTINE CALCFSPACE
 749: 
 750: SUBROUTINE FINDDISPS(NATOMS,COORDSA,COORDSB,NWAVE,WAVEK,KWIDTH,NFSPACE,DISPS,NDISPS,DEBUG)
 751: !
 752: ! Performs FASTOVERLAP alignment for periodic 3D structures
 753: !
 754: ! Calculates up to NDISPS possible displacements to align coordinates COORDSA and COORDSB
 755: ! Outputs DISPS as fractional coordinates, so DISPS must be multiplied by the lattice vector
 756: ! to obtain the full displacements
 757: !
 758: USE FASTOVERLAPUTILS, ONLY: FINDPEAKS
 759: IMPLICIT NONE
 760: INTEGER, INTENT(IN) :: NATOMS, NWAVE, NFSPACE
 761: INTEGER, INTENT(INOUT) :: NDISPS
 762: LOGICAL, INTENT(IN) :: DEBUG
 763: DOUBLE PRECISION, INTENT(IN) :: KWIDTH, COORDSA(3*NATOMS), COORDSB(3*NATOMS), WAVEK(3, 2*NWAVE+1,2*NWAVE+1,2*NWAVE+1)
 764: DOUBLE PRECISION, INTENT(OUT) :: DISPS(NDISPS,3)
 765: 
 766: INTEGER J
 767: DOUBLE PRECISION FSPACE(NFSPACE, NFSPACE, NFSPACE), AMPLITUDES(NDISPS)
 768: 
 769: CALL CALCFSPACE(NATOMS,COORDSA,COORDSB,NWAVE,WAVEK,KWIDTH,NFSPACE,FSPACE)!,NPERMGROUP)
 770: 
 771: CALL FINDPEAKS(FSPACE, DISPS, AMPLITUDES, NDISPS, DEBUG)
 772: 
 773: DISPS = DISPS - 1.D0
 774: DO J=1,NDISPS
 775:     DISPS(J,:) = DISPS(J,:)/(/NFSPACE,NFSPACE,NFSPACE/)
 776: ENDDO
 777: 
 778: END SUBROUTINE FINDDISPS
 779: 
 780: SUBROUTINE SETBULK()
784: 781: 
785: USE COMMONS, ONLY : MYUNIT,NFREEZE,GEOMDIFFTOL,ORBITTOL,FREEZE,PULLT,TWOD,  &782: USE COMMONS, ONLY : MYUNIT,NFREEZE,GEOMDIFFTOL,ORBITTOL,FREEZE,PULLT,TWOD,  &
786:     &   EFIELDT,AMBERT,QCIAMBERT,AMBER12T,CHRMMT,STOCKT,CSMT,PERMDIST,      &783:     &   EFIELDT,AMBERT,QCIAMBERT,AMBER12T,CHRMMT,STOCKT,CSMT,PERMDIST,      &
787:     &   LOCALPERMDIST,LPERMDIST,OHCELLT,QCIPERMCHECK,PERMOPT,PERMINVOPT,    &784:     &   LOCALPERMDIST,LPERMDIST,OHCELLT,QCIPERMCHECK,PERMOPT,PERMINVOPT,    &
788:     &   NOINVERSION,GTHOMSONT,MKTRAPT,MULLERBROWNT,RIGID785:     &   NOINVERSION,GTHOMSONT,MKTRAPT,MULLERBROWNT,RIGID,OHCELLT
789: 786: 
790: IMPLICIT NONE787: IMPLICIT NONE
791: 788: 
792: IF((.NOT.ALLOCATED(PERMGROUP)).OR.(.NOT.ALLOCATED(NPERMSIZE))) THEN789: MYUNIT = 6
793:     WRITE(*,'(A)') 'ERROR - permutation arrays not set, use PERMOPT keyword'790: NFREEZE = 0
794:     STOP791: GEOMDIFFTOL = 0.5D0
795: ENDIF792: ORBITTOL = 1.0D-3
 793: 
 794: FREEZE = .FALSE.
 795: PULLT = .FALSE.
 796: TWOD = .FALSE.
 797: EFIELDT = .FALSE.
 798: AMBERT = .FALSE.
 799: QCIAMBERT = .FALSE.
 800: AMBER12T = .FALSE.
 801: CHRMMT = .FALSE.
 802: STOCKT = .FALSE.
 803: CSMT = .FALSE.
 804: PERMDIST = .FALSE.
 805: LOCALPERMDIST = .FALSE.
 806: LPERMDIST = .FALSE.
 807: QCIPERMCHECK = .FALSE.
 808: PERMOPT = .FALSE.
 809: PERMINVOPT = .FALSE.
 810: NOINVERSION = .FALSE.
 811: GTHOMSONT = .FALSE.
 812: MKTRAPT = .FALSE.
 813: MULLERBROWNT = .FALSE.
 814: RIGID = .FALSE.
 815: OHCELLT = .FALSE.
 816: 
 817: END SUBROUTINE SETBULK
 818: 
 819: SUBROUTINE CHECKKEYWORDS()
796: 820: 
797: IF(PERMINVOPT) THEN821: USE COMMONS, ONLY : MYUNIT,NFREEZE,GEOMDIFFTOL,ORBITTOL,FREEZE,PULLT,TWOD,  &
798:     WRITE(*,'(A)') 'ERROR - bulk fastoverlap not compatible with PERMINVOPT keyword'822:     &   EFIELDT,AMBERT,QCIAMBERT,AMBER12T,CHRMMT,STOCKT,CSMT,PERMDIST,      &
 823:     &   LOCALPERMDIST,LPERMDIST,OHCELLT,QCIPERMCHECK,PERMOPT,PERMINVOPT,    &
 824:     &   NOINVERSION,GTHOMSONT,MKTRAPT,MULLERBROWNT,RIGID,OHCELLT
 825: 
 826: IMPLICIT NONE
 827: 
 828: IF(PERMINVOPT .OR. PERMOPT) THEN
 829:     WRITE(*,'(A)') 'ERROR - bulk fastoverlap not compatible with PERMINVOPT or PERMOPT keywords'
799:     WRITE(*,'(A)') 'use keyword OHCELL to use octahedral symmetries'830:     WRITE(*,'(A)') 'use keyword OHCELL to use octahedral symmetries'
800:     STOP831:     STOP
801: ENDIF832: ENDIF
802: 833: 
803: IF(STOCKT) THEN834: IF(STOCKT) THEN
804:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with STOCK keyword'835:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with STOCK keyword'
805:     STOP836:     STOP
806: ENDIF837: ENDIF
807: 838: 
808: IF(CSMT) THEN839: IF(CSMT) THEN
838: IF(GTHOMSONT) THEN869: IF(GTHOMSONT) THEN
839:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with GTHOMSON keyword'870:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with GTHOMSON keyword'
840:     STOP871:     STOP
841: ENDIF872: ENDIF
842: 873: 
843: IF(MKTRAPT) THEN874: IF(MKTRAPT) THEN
844:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with MKTRAP keyword'875:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with MKTRAP keyword'
845:     STOP876:     STOP
846: ENDIF877: ENDIF
847: 878: 
 879: IF(TWOD) THEN
 880:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with TWOD keyword'
 881:     STOP
 882: ENDIF
 883: 
848: END SUBROUTINE CHECKKEYWORDS884: END SUBROUTINE CHECKKEYWORDS
849: 885: 
 886: SUBROUTINE ALIGN2(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,DISTANCE,DIST2,DISPBEST,NDISPS)
 887: 
 888: ! COORDSA becomes the optimal alignment of the optimal permutation of COORDSB
 889: ! DISTANCE returns
 890: ! TWOD, RIGID aren't currently implemented
 891: ! DEBUG doesn't do anything either
 892: 
 893: USE FASTOVERLAPUTILS, ONLY: FASTLEN, FINDBESTPERMUTATION
 894: IMPLICIT NONE
 895: 
 896: INTEGER, INTENT(IN) :: NATOMS, NDISPS
 897: ! These currently aren't used, but are included to match call signature of minpermdist
 898: LOGICAL, INTENT(IN) :: DEBUG
 899: DOUBLE PRECISION, INTENT(IN) :: BOXLX, BOXLY, BOXLZ
 900: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NATOMS), COORDSB(3*NATOMS)
 901: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2, DISPBEST(3)
 902: 
 903: DOUBLE PRECISION, ALLOCATABLE :: WAVEK(:,:,:,:)
 904: DOUBLE PRECISION DISPS(NDISPS, 3), KERNELWIDTH, MAXWAVEK, BOX(3)
 905: INTEGER NWAVE, NFSPACE, FOUNDDISPS, J, J1, J2, IND1, IND2
 906: 
 907: DOUBLE PRECISION PDUMMYA(3*NATOMS), PDUMMYB(3*NATOMS), DUMMYA(3*NATOMS), DUMMYB(3*NATOMS),&
 908:     DUMMY(3*NATOMS), LDISTANCE, WORSTRAD, CURRDIST, DISPSAVE(3), DISP1D(NATOMS), DISP(3, NATOMS)
 909: INTEGER SAVEPERM(NATOMS), NDUMMY, PATOMS
 910: 
 911: DOUBLE PRECISION PERMDIST
 912: 
 913: BOX = (/BOXLX, BOXLY, BOXLZ/)
 914: 
 915: ! Calculate kernel width automatically if not specified
 916: IF (KWIDTH.EQ.0.D0) THEN
 917:     KERNELWIDTH = (BOXLX*BOXLY*BOXLZ/NATOMS)**(1.D0/3.D0) / 3.D0
 918: ELSE
 919:     KERNELWIDTH = KWIDTH
 920: ENDIF
 921: 
 922: ! Number of wavevectors that we need to preserve reasonable level of accuracy
 923: MAXWAVEK = 1.5 / KERNELWIDTH
 924: NWAVE = CEILING(2*3.14159265359/MINVAL(BOX)*MAXWAVEK, 4)
 925: ALLOCATE(WAVEK(3,2*NWAVE+1,2*NWAVE+1,2*NWAVE+1))
 926: CALL SETWAVEK(NWAVE,WAVEK,BOXLX,BOXLY,BOXLZ)
 927: 
 928: ! Setting size of Fourier Transform array to be fast
 929: ! This also increases the resolution of the method
 930: IF((2*NWAVE+1).LE.200) THEN
 931:     NFSPACE = FASTLEN(4*NWAVE+3)
 932: ELSE
 933:     ! PROBABLY NOT THE BEST WAY TO CALCULATE THIS!
 934:     NFSPACE = 2**CEILING(LOG(4.D0*NWAVE+3.D0)/LOG(2.D0),4)
 935: ENDIF
 936: 
 937: FOUNDDISPS = NDISPS
 938: ! FASTOVERLAP alignment
 939: CALL FINDDISPS(NATOMS,COORDSB,COORDSA,NWAVE,WAVEK,KERNELWIDTH,NFSPACE,DISPS,FOUNDDISPS,DEBUG)
 940: IF (DEBUG) WRITE(MYUNIT,'(A,I3,A)') 'fastoverlap> found ', NDISPS, ' candidate displacements'
 941: 
 942: ! Perform permutational alignment for each displacement, keep the best
 943: DISTANCE = HUGE(DISTANCE)
 944: DUMMYB = COORDSB
 945: DO J=1,FOUNDDISPS
 946:     DISPS(J,:) = DISPS(J,:)*BOX
 947: 
 948:     IF (DEBUG) WRITE(MYUNIT,'(A,I3)') 'fastoverlap> testing displacement', J
 949:     IF (DEBUG) WRITE(MYUNIT,'(3G20.10)') DISPS(J,:)
 950: 
 951:     DO J1=1,NATOMS
 952:         DUMMYA(3*J1-2:3*J1) = COORDSA(3*J1-2:3*J1) - DISPS(J,:)
 953:     ENDDO
 954:     CALL FINDBESTPERMUTATION(NATOMS, DUMMYB, DUMMYA, BOXLX, BOXLY, BOXLZ, .TRUE., SAVEPERM, CURRDIST, DIST2, WORSTRAD)
 955: 
 956:     IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> after permutation distance=', SQRT(CURRDIST)
 957: 
 958:     IF(CURRDIST.LT.DISTANCE) THEN
 959:         DISTANCE = CURRDIST
 960:         NDUMMY=0
 961:         DISPBEST = DISPS(J,:)
 962: !        BESTPERM=SAVEPERM
 963:     ELSE
 964:     IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> best found distance=', SQRT(DISTANCE)
 965:     ENDIF
 966: ENDDO
 967: 
 968: 
 969: DO J1=1,NATOMS
 970:     COORDSA(3*J1-2:3*J1) = COORDSA(3*J1-2:3*J1) - DISPBEST
 971: ENDDO
 972: 
 973: CALL MEDIANMINPERMDIST(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,DISTANCE,DIST2,DISPSAVE,DISP)
 974: 
 975: DISPBEST = DISPBEST + DISPSAVE
 976: 
 977: IF (DEBUG) THEN
 978:     WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> overall best found distance=', DISTANCE
 979:     WRITE(MYUNIT,'(A)') 'fastoverlap> overall best displacement:'
 980:     WRITE(MYUNIT,'(3G20.10)') DISPBEST
 981: ENDIF
 982: 
 983: END SUBROUTINE ALIGN2
 984: 
 985: SUBROUTINE MEDIANMINPERMDIST(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,DISTANCE,DIST2,DISPBEST,DISP)
 986: ! COORDSA becomes the optimal alignment of the optimal permutation of COORDSB
 987: ! BESTPERM in the COMMONS module stores the best found permutation
 988: ! DISPBEST returns the displacement corresponding to the best displacement
 989: 
 990: USE COMMONS, ONLY : BESTPERM
 991: USE FASTOVERLAPUTILS, ONLY: FINDBESTPERMUTATION
 992: IMPLICIT NONE
 993: 
 994: INTEGER, INTENT(IN) :: NATOMS
 995: LOGICAL, INTENT(IN) :: DEBUG
 996: DOUBLE PRECISION, INTENT(IN) :: BOXLX, BOXLY, BOXLZ
 997: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NATOMS), COORDSB(3*NATOMS)
 998: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2, DISPBEST(3), DISP(3,NATOMS)
 999: 
 1000: INTEGER, PARAMETER :: MAXIMUMTRIES=20
 1001: INTEGER I, J, J1, J2, IND1, IND2, SAVEPERM(NATOMS), NPERM
 1002: 
 1003: DOUBLE PRECISION PDUMMYA(3*NATOMS), PDUMMYB(3*NATOMS), DUMMYA(3*NATOMS), DUMMYB(3*NATOMS),&
 1004:     DUMMY(3*NATOMS), LDISTANCE, WORSTRAD, CURRDIST, MDISP(3), DISP1D(NATOMS), BOX(3), DISTSAVE
 1005: 
 1006: DOUBLE PRECISION PERMDIST
 1007: 
 1008: DISPBEST = 0.D0
 1009: BOX = (/BOXLX, BOXLY, BOXLZ/)
 1010: 
 1011: DUMMYA(1:3*NATOMS) = COORDSA(1:3*NATOMS)
 1012: DUMMYB(1:3*NATOMS) = COORDSB(1:3*NATOMS)
 1013: 
 1014: DO I=1,MAXIMUMTRIES
 1015: 
 1016: CALL FINDBESTPERMUTATION(NATOMS, DUMMYB, DUMMYA, BOXLX, BOXLY, BOXLZ, .TRUE., SAVEPERM, DISTSAVE, DIST2, WORSTRAD)
 1017: !SAVEPERM(1:NATOMS) = BESTPERM(1:NATOMS)
 1018: 
 1019: IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') 'medianminpermdist> distance after permuting', SQRT(DISTSAVE)
 1020: 
 1021: CALL GETDISPLACEMENT(DISP, NATOMS, DUMMYB, DUMMYA, SAVEPERM, BOX)
 1022: 
 1023: DO J=1,3
 1024:     DISP1D = DISP(J,:)
 1025:     CALL MEDIAN(DISP1D, NATOMS, MDISP(J))
 1026: ENDDO
 1027: 
 1028: IF (DEBUG) WRITE(MYUNIT,'(A)') 'medianminpermdist> median displacement:'
 1029: IF (DEBUG) WRITE(MYUNIT,'(3G20.10)') MDISP
 1030: 
 1031: DISPBEST = DISPBEST + MDISP
 1032: DO J1=1,NATOMS
 1033:     DUMMYA(3*J1-2:3*J1) = COORDSA(3*J1-2:3*J1) - DISPBEST
 1034: ENDDO
 1035: 
 1036: ! Recalculate permutational alignment
 1037: CALL FINDBESTPERMUTATION(NATOMS, DUMMYB, DUMMYA, BOXLX, BOXLY, BOXLZ, .TRUE., BESTPERM, DISTANCE, DIST2, WORSTRAD)
 1038: 
 1039: IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') 'medianminpermdist> distance after subtracting median', SQRT(DISTANCE)
 1040: 
 1041: ! Find and subtract mean displacement
 1042: CALL GETDISPLACEMENT(DISP, NATOMS, DUMMYB, DUMMYA, BESTPERM, BOX)
 1043: DO J=1,3
 1044:     MDISP(J) = SUM(DISP(J,:))/NATOMS
 1045: ENDDO
 1046: DISPBEST = DISPBEST - MDISP
 1047: DO J1=1,NATOMS
 1048:     DUMMYA(3*J1-2:3*J1) = COORDSA(3*J1-2:3*J1) - DISPBEST
 1049: ENDDO
 1050: 
 1051: NPERM=0
 1052: DO J1=1,NATOMS
 1053:     IF(SAVEPERM(J1).NE.BESTPERM(J1)) NPERM = NPERM + 1
 1054: ENDDO
 1055: 
 1056: IF (DEBUG) WRITE(MYUNIT,'(A,I4,A)') 'medianminpermdist> permuted', NPERM, ' pairs of atoms'
 1057: 
 1058: IF (NPERM.EQ.0) EXIT
 1059: 
 1060: IF (DISTANCE>DISTSAVE) THEN
 1061:     IF (DEBUG) WRITE(MYUNIT,'(A)') &
 1062:   & 'medianminpermdist> WARNING - distance increased with nonzero permutations, aborting'
 1063:     DUMMYA(1:3*NATOMS) = COORDSA(1:3*NATOMS)
 1064:     BESTPERM(1:NATOMS) = SAVEPERM(1:NATOMS)
 1065:     EXIT
 1066: ENDIF
 1067: 
 1068: ENDDO
 1069: 
 1070: IF (I.EQ.MAXIMUMTRIES) THEN
 1071:     IF (DEBUG) WRITE(MYUNIT,'(A)') &
 1072:   & 'medianminpermdist> WARNING - number of tries exceeded'
 1073: ENDIF
 1074: 
 1075: DO J1=1,NATOMS
 1076:     SAVEPERM(J1) = J1
 1077:     J2 = BESTPERM(J1)
 1078:     COORDSA(3*J1-2:3*J1) = DUMMYA(3*J2-2:3*J2)
 1079: ENDDO
 1080: 
 1081: CALL GETDISTANCE(DISTANCE, NATOMS, COORDSB, COORDSA, SAVEPERM, BOX)
 1082: 
 1083: DISTANCE = DISTANCE**0.5
 1084: 
 1085: IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') 'medianminpermdist> final distance', DISTANCE
 1086: 
 1087: END SUBROUTINE MEDIANMINPERMDIST
 1088: 
 1089: SUBROUTINE GETDISTANCE(DIST, NATOMS, COORDSB, COORDSA, PERMLIST, BOX)
 1090: 
 1091: ! Calculates distance between two bulk structures given a permutation
 1092: ! specified by PERMLIST
 1093: !USE COMMONS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP
 1094: IMPLICIT NONE
 1095: 
 1096: INTEGER, INTENT(IN) ::NATOMS
 1097: DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NATOMS), COORDSB(3*NATOMS), BOX(3)
 1098: INTEGER, INTENT(IN) :: PERMLIST(NATOMS)
 1099: DOUBLE PRECISION, INTENT(OUT) :: DIST
 1100: 
 1101: DOUBLE PRECISION PERMDIST
 1102: INTEGER J1, J2, PATOMS, NDUMMY, IND1, IND2
 1103: 
 1104: DIST = 0.D0
 1105: NDUMMY=0
 1106: 
 1107: DO J1=1,NPERMGROUP
 1108:     PATOMS=NPERMSIZE(J1)
 1109:     DO J2=1,PATOMS
 1110:         IND1 = J2+NDUMMY
 1111:         IND2 = PERMLIST(J2+NDUMMY)
 1112:         DIST = DIST + PERMDIST(COORDSB(3*IND1-2),COORDSA(3*IND2-2),BOX,.TRUE.)
 1113:     ENDDO
 1114:     NDUMMY = NDUMMY+PATOMS
 1115: ENDDO
 1116: 
 1117: END SUBROUTINE GETDISTANCE
850: 1118: 
851: SUBROUTINE GETDISPLACEMENT(DISP, NCOORDS, COORDSB, COORDSA, PERMLIST, BOX)1119: SUBROUTINE GETDISPLACEMENT(DISP, NATOMS, COORDSB, COORDSA, PERMLIST, BOX)
852: 1120: 
853: ! Calculates minimum displacement between atoms in two bulk structures given a1121: ! Calculates minimum displacement between atoms in two bulk structures given a
854: ! permutation specified by PERMLIST1122: ! permutation specified by PERMLIST
 1123: !USE COMMONS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP
855: IMPLICIT NONE1124: IMPLICIT NONE
856: 1125: 
857: INTEGER, INTENT(IN) :: NCOORDS1126: INTEGER, INTENT(IN) :: NATOMS
858: DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS), BOX(3)1127: DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NATOMS), COORDSB(3*NATOMS), BOX(3)
859: INTEGER, INTENT(IN) :: PERMLIST(NCOORDS)1128: INTEGER, INTENT(IN) :: PERMLIST(NATOMS)
860: DOUBLE PRECISION, INTENT(OUT) :: DISP(3, NCOORDS)1129: DOUBLE PRECISION, INTENT(OUT) :: DISP(3, NATOMS)
861: 1130: 
862: DOUBLE PRECISION :: D(3)1131: DOUBLE PRECISION :: D(3)
863: INTEGER J1, J2, PATOMS, NDUMMY, IND1, IND21132: INTEGER J1, J2, PATOMS, NDUMMY, IND1, IND2
864: 1133: 
865: NDUMMY=01134: NDUMMY=0
866: DO J1=1,NPERMGROUP1135: DO J1=1,NPERMGROUP
867:     PATOMS=NPERMSIZE(J1)1136:     PATOMS=NPERMSIZE(J1)
868:     DO J2=1,PATOMS1137:     DO J2=1,PATOMS
869:         IND1 = J2+NDUMMY1138:         IND1 = J2+NDUMMY
870:         IND2 = PERMLIST(J2+NDUMMY)1139:         IND2 = PERMLIST(J2+NDUMMY)


r33355/fastclusters.f90 2017-09-28 12:30:15.355922039 +0100 r33354/fastclusters.f90 2017-09-28 12:30:17.139945524 +0100
  1: !    FASTOVERLAP  1: !    FASTOVERLAP
  2: !  2: !
  3: !    FORTRAN Module for calculating Fast SO(3) Fourier transforms (SOFTs)  3: !    FORTRAN Module for calculating Fast SO(3) Fourier transforms (SOFTs)
  4: !    Copyright (C) 2017  Matthew Griffiths  4: !    Copyright (C) 2017  Matthew Griffiths
  5: !  5: !    
  6: !    This program is free software; you can redistribute it and/or modify  6: !    This program is free software; you can redistribute it and/or modify
  7: !    it under the terms of the GNU General Public License as published by  7: !    it under the terms of the GNU General Public License as published by
  8: !    the Free Software Foundation; either version 2 of the License, or  8: !    the Free Software Foundation; either version 2 of the License, or
  9: !    (at your option) any later version.  9: !    (at your option) any later version.
 10: ! 10: !    
 11: !    This program is distributed in the hope that it will be useful, 11: !    This program is distributed in the hope that it will be useful,
 12: !    but WITHOUT ANY WARRANTY; without even the implied warranty of 12: !    but WITHOUT ANY WARRANTY; without even the implied warranty of
 13: !    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 13: !    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 14: !    GNU General Public License for more details. 14: !    GNU General Public License for more details.
 15: ! 15: !    
 16: !    You should have received a copy of the GNU General Public License along 16: !    You should have received a copy of the GNU General Public License along
 17: !    with this program; if not, write to the Free Software Foundation, Inc., 17: !    with this program; if not, write to the Free Software Foundation, Inc.,
 18: !    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 18: !    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 19:  19: 
 20:  20: 
 21: !    Includes code from https://people.sc.fsu.edu/~jburkardt/f_src/special_functions/special_functions.html 21: !    Includes code from https://people.sc.fsu.edu/~jburkardt/f_src/special_functions/special_functions.html
 22: ! 22: !
 23: !    Reference: 23: !    Reference:
 24: ! 24: !
 25: !    Shanjie Zhang, Jianming Jin, 25: !    Shanjie Zhang, Jianming Jin,
 30:  30: 
 31: !*********************************************************************** 31: !***********************************************************************
 32: ! CLUSTERFASTOVERLAP MODULE 32: ! CLUSTERFASTOVERLAP MODULE
 33: !*********************************************************************** 33: !***********************************************************************
 34:  34: 
 35: ! Subroutines: 35: ! Subroutines:
 36: ! 36: !
 37: !    FOM_ALIGN_CLUSTERS(COORDSB, COORDSA, NATOMS, DEBUG, L, KWIDTH, DISTANCE, DIST2, RMATBEST, NROTATIONS) 37: !    FOM_ALIGN_CLUSTERS(COORDSB, COORDSA, NATOMS, DEBUG, L, KWIDTH, DISTANCE, DIST2, RMATBEST, NROTATIONS)
 38: !        MAIN ALIGNMENT ALGORITHM ROUTINE 38: !        MAIN ALIGNMENT ALGORITHM ROUTINE
 39: !        KWIDTH is the Gaussian Kernel width, this should probably be set to ~1/3 interatomic separation. 39: !        KWIDTH is the Gaussian Kernel width, this should probably be set to ~1/3 interatomic separation.
 40: !        Performs alignment using SO(3) Coefficients calculated directly. 40: !        Performs alignment using SO(3) Coefficients calculated directly. 
 41: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated 41: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated
 42: ! 42: !   
 43: !    ALIGNHARM(COORDSB, COORDSA, NATOMS, DEBUG, N, L, HWIDTH, KWIDTH, DISTANCE, DIST2, RMATBEST, NROTATIONS) 43: !    ALIGNHARM(COORDSB, COORDSA, NATOMS, DEBUG, N, L, HWIDTH, KWIDTH, DISTANCE, DIST2, RMATBEST, NROTATIONS)
 44: !        Performs alignment using SO(3) Coefficients calculated using Quantum Harmonic Oscillator Basis 44: !        Performs alignment using SO(3) Coefficients calculated using Quantum Harmonic Oscillator Basis 
 45: !        KWIDTH is the Gaussian Kernel width,  HWIDTH is the Quantum Harmonic Oscillator Basis length scale 45: !        KWIDTH is the Gaussian Kernel width,  HWIDTH is the Quantum Harmonic Oscillator Basis length scale
 46: !        These need to be carefully chosen along with N and L to ensure calculation is stable and accurate. 46: !        These need to be carefully chosen along with N and L to ensure calculation is stable and accurate.
 47: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated 47: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated
 48: ! 48: ! 
 49: !    ALIGNCOEFFS(COORDSB,COORDSA,NATOMS,IMML,L,DEBUG,DISTANCE,DIST2,RMATBEST,NROTATIONS,ANGLES) 49: !    ALIGNCOEFFS(COORDSB,COORDSA,NATOMS,IMML,L,DEBUG,DISTANCE,DIST2,RMATBEST,NROTATIONS,ANGLES)
 50: !        Primary alignment routine, called by ALIGN1 50: !        Primary alignment routine, called by ALIGN1
 51: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated 51: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated
 52: ! 52: !
 53: !    HARMONIC0L(L, RJ, SIGMA, R0, RET) 53: !    HARMONIC0L(L, RJ, SIGMA, R0, RET)
 54: !        Calculates the Harmonic integral when n=0 54: !        Calculates the Harmonic integral when n=0
 55: ! 55: !
 56: !    HARMONICNL(N,L,RJ,SIGMA,R0,RET) 56: !    HARMONICNL(N,L,RJ,SIGMA,R0,RET)
 57: !        Calculates Harmonic integral up to N,L 57: !        Calculates Harmonic integral up to N,L
 58: !        Note calculation unstable, so SIGMA must be > 10 RJ to get good results 58: !        Note calculation unstable, so SIGMA must be > 10 RJ to get good results
 59: ! 59: !    
 60: !    RYML(COORD, R, YML, L) 60: !    RYML(COORD, R, YML, L)
 61: !        Calculates |COORD| and the Spherical Harmonic associated with COORD up to l 61: !        Calculates |COORD| and the Spherical Harmonic associated with COORD up to l
 62: ! 62: !    
 63: !    HARMONICCOEFFS(COORDS, NATOMS, CNML, N, L, HWIDTH, KWIDTH) 63: !    HARMONICCOEFFS(COORDS, NATOMS, CNML, N, L, HWIDTH, KWIDTH)
 64: !        Projects structure into Quantum Harmonic Oscillator Basis with scale HWIDTH and 64: !        Projects structure into Quantum Harmonic Oscillator Basis with scale HWIDTH and
 65: !        Gaussian kernel width KWIDTH up to order N and angular moment degree L 65: !        Gaussian kernel width KWIDTH up to order N and angular moment degree L
 66: ! 66: !    
 67: !    DOTHARMONICCOEFFS(C1NML, C2NML, N, L, IMML) 67: !    DOTHARMONICCOEFFS(C1NML, C2NML, N, L, IMML)
 68: !        Calculates the SO(3) Fourier Coefficients of the overlap integral of two 68: !        Calculates the SO(3) Fourier Coefficients of the overlap integral of two 
 69: !        structures with coefficient arrays C1NML and C2NML 69: !        structures with coefficient arrays C1NML and C2NML
 70: ! 70: !    
 71: !    FOURIERCOEFFS(COORDSB, COORDSA, NATOMS, L, KWIDTH, IMML, YMLB, YMLA) 71: !    FOURIERCOEFFS(COORDSB, COORDSA, NATOMS, L, KWIDTH, IMML, YMLB, YMLA)
 72: !        Calculates the SO(3) Fourier Coefficients of the overlap integral of two 72: !        Calculates the SO(3) Fourier Coefficients of the overlap integral of two 
 73: !        structures directly by calculating the coefficients of the NATOMS**2 73: !        structures directly by calculating the coefficients of the NATOMS**2
 74: !        Gaussian overlap functions. 74: !        Gaussian overlap functions.
 75: ! 75: !    
 76: !    CALCOVERLAP(IMML, OVERLAP, L, ILMM) 76: !    CALCOVERLAP(IMML, OVERLAP, L, ILMM)
 77: !        Calculates the overlap integral array from SO(3) Fourier Coefficients IMML 77: !        Calculates the overlap integral array from SO(3) Fourier Coefficients IMML
 78: !        Also returns ILMM, the transposed and rolled version of IMML used by DSOFT 78: !        Also returns ILMM, the transposed and rolled version of IMML used by DSOFT
 79: ! 79: !    
 80: !    FINDROTATIONS(OVERLAP, L, ANGLES, AMPLITUDES, NROTATIONS, DEBUG) 80: !    FINDROTATIONS(OVERLAP, L, ANGLES, AMPLITUDES, NROTATIONS, DEBUG)
 81: !        Finds the maximum overlap Euler angles of an overlap integral array 81: !        Finds the maximum overlap Euler angles of an overlap integral array
 82: ! 82: !    
 83: !    EULERM(A,B,G,ROTM) 83: !    EULERM(A,B,G,ROTM)
 84: !        Calculates rotation matrix, ROTM, corresponding to  Euler angles, a,b,g 84: !        Calculates rotation matrix, ROTM, corresponding to  Euler angles, a,b,g
 85: ! 85: !    
 86: !    EULERINVM(A,B,G,ROTM) 86: !    EULERINVM(A,B,G,ROTM)
 87: !        Calculates transpose/inverse of rotation matrix corresponding to Euler angles, a,b,g 87: !        Calculates transpose/inverse of rotation matrix corresponding to Euler angles, a,b,g
 88: ! 88: !    
  89: !    SETCLUSTER()
  90: !        Used to set keywords if they're not set already
  91: !    
 89: !    CHECKKEYWORDS() 92: !    CHECKKEYWORDS()
 90: !        Sanity checks for the keywords 93: !        Sanity checks for the keywords
 91:  94: 
 92: !*********************************************************************** 95: !***********************************************************************
 93:  96: 
 94: ! EXTERNAL SUBROUTINES 97: ! EXTERNAL SUBROUTINES
 95: !    MINPERMDIST (minpermdist.f90) depends on (bulkmindist.f90,minperm.f90,newmindist.f90,orient.f90) 98: !    MINPERMDIST (minpermdist.f90) depends on (bulkmindist.f90,minperm.f90,newmindist.f90,orient.f90)
 96: !    XDNRMP (legendre.f90) 99: !    XDNRMP (legendre.f90)
 97: !        Needed to calculate Legendre polynomials100: !        Needed to calculate Legendre polynomials
 98: 101: 
 99: !***********************************************************************102: !***********************************************************************
100: 103: 
101: ! EXTERNAL MODULES104: ! EXTERNAL MODULES
102: !    COMMONS (commons.f90)105: !    COMMONS (commons.f90)
103: !    ALIGNUTILS depends on LAPACK106: !    FASTOVERLAPUTILS (fastutils.f90) depends on (minperm.f90)
104: !        Module for alignment routines, including a reduced version of MINPERMDIST 
105: !    FASTOVERLAPUTILS (fastutils.f90) 
106: !        Helper Module Needed for Peak Fitting and FFT routines107: !        Helper Module Needed for Peak Fitting and FFT routines
107: !    DSOFT (DSOFT.f90)108: !    DSOFT (DSOFT.f90) 
108: !        Module for performing discrete SO(3) transforms, depends on fftw.109: !        Module for performing discrete SO(3) transforms, depends on fftw.
109: 110: 
110: !***********************************************************************111: !***********************************************************************
111: 112: 
112: !INCLUDE "commons.f90" 
113: !INCLUDE "alignutils.f90" 
114: !INCLUDE "fastutils.f90" 
115: !INCLUDE "DSOFT.f90" 
116:  
117: MODULE CLUSTERFASTOVERLAP113: MODULE CLUSTERFASTOVERLAP
118: 114: 
119: USE ALIGNUTILS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP, NATOMS, BESTPERM, MYUNIT, &115: USE COMMONS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP, NATOMS, BESTPERM, MYUNIT
120:  & SAVECOORDS, NSTORED, PERMINVOPT, NOINVERSION 
121: USE FASTOVERLAPUTILS, ONLY : DUMMYA, DUMMYB, XBESTA, XBESTASAVE116: USE FASTOVERLAPUTILS, ONLY : DUMMYA, DUMMYB, XBESTA, XBESTASAVE
122: USE PREC, ONLY: INT64, REAL64117: USE PREC, ONLY: INT64, REAL64
123: 118: 
124: LOGICAL, SAVE :: PERMINVOPTSAVE, NOINVERSIONSAVE119: LOGICAL, SAVE :: PERMINVOPTSAVE, NOINVERSIONSAVE
125: 120: 
126: DOUBLE PRECISION, PARAMETER :: PI = 3.141592653589793D0121: DOUBLE PRECISION, PARAMETER :: PI = 3.141592653589793D0
127: 122: 
128: CONTAINS123: CONTAINS
129: 124: 
130: SUBROUTINE FOM_ALIGN_CLUSTERS(COORDSB, COORDSA, NCOORDS, DEBUG, L, KWIDTH, DISTANCE, DIST2, RMATBEST, NROTATIONS)125: SUBROUTINE FOM_ALIGN_CLUSTERS(COORDSB, COORDSA, NATOMS, DEBUG, L, KWIDTH, DISTANCE, DIST2, RMATBEST, NROTATIONS)
131: 126: 
132: !  COORDSA becomes the optimal alignment of the optimal permutation(-inversion)127: !  COORDSA becomes the optimal alignment of the optimal permutation(-inversion)
133: !  isomer. DISTANCE is the residual square distance for the best alignment with128: !  isomer. DISTANCE is the residual square distance for the best alignment with 
134: !  respect to permutation(-inversion)s as well as orientation and centre of mass.129: !  respect to permutation(-inversion)s as well as orientation and centre of mass.
135: !  COORDSA and COORDSB are both centred on the ORIGIN130: !  COORDSA and COORDSB are both centred on the ORIGIN
136: 131: 
137: !  KWIDTH is the width of the Gaussian kernels that are centered on each of the132: !  KWIDTH is the width of the Gaussian kernels that are centered on each of the
138: !  atomic coordinates, whose overlap integral is maximised to find the optimal133: !  atomic coordinates, whose overlap integral is maximised to find the optimal
139: !  rotations134: !  rotations
140: 135: 
141: !  RMATBEST gives the optimal rotation matrix136: !  RMATBEST gives the optimal rotation matrix
142: 137: 
143: !  L is the maximum angular momentum degree up to which the SO(3) coefficients138: !  L is the maximum angular momentum degree up to which the SO(3) coefficients 
144: !  are calculated number of coefficients that will be calculated = 1/3 (L+1)(2L+1)(2L+3)139: !  are calculated number of coefficients that will be calculated = 1/3 (L+1)(2L+1)(2L+3)
145: 140: 
146: !  Number of Calculations for SO(3) calculations ~ O(1/3 (L+1)(2L+1)(2L+3) * NATOMS**2)141: !  Number of Calculations for SO(3) calculations ~ O(1/3 (L+1)(2L+1)(2L+3) * NATOMS**2)
147: 142: 
148: USE FASTOVERLAPUTILS, ONLY : SETNATOMS143: USE COMMONS, ONLY: BESTPERM, PERMOPT, PERMINVOPT, NOINVERSION, CHRMMT, AMBERT, AMBER12T
 144: USE FASTOVERLAPUTILS, ONLY: SETNATOMS
149: IMPLICIT NONE145: IMPLICIT NONE
150: 146: 
151: INTEGER, INTENT(IN) :: NCOORDS, L147: INTEGER, INTENT(IN) :: NATOMS, L
152: INTEGER, INTENT(IN) :: NROTATIONS148: INTEGER, INTENT(IN) :: NROTATIONS
153: LOGICAL, INTENT(IN) :: DEBUG149: LOGICAL, INTENT(IN) :: DEBUG
154: DOUBLE PRECISION, INTENT(INOUT) :: KWIDTH ! Gaussian Kernel width150: DOUBLE PRECISION, INTENT(INOUT) :: KWIDTH ! Gaussian Kernel width
155: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS)151: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NATOMS), COORDSB(3*NATOMS)
156: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2, RMATBEST(3,3)152: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2, RMATBEST(3,3)
157: 153: 
158: COMPLEX(KIND=REAL64) PIMML(-L:L,-L:L,0:L)154: COMPLEX(KIND=REAL64) PIMML(-L:L,-L:L,0:L)
159: COMPLEX(KIND=REAL64) IMML(-L:L,-L:L,0:L), YMLA(-L:L,0:L,NCOORDS), YMLB(-L:L,0:L,NCOORDS)155: COMPLEX(KIND=REAL64) IMML(-L:L,-L:L,0:L), YMLA(-L:L,0:L,NATOMS), YMLB(-L:L,0:L,NATOMS)
160: 156: 
161: DOUBLE PRECISION SAVEA(3*NCOORDS),SAVEB(3*NCOORDS),COMA(3),COMB(3)157: DOUBLE PRECISION SAVEA(3*NATOMS),SAVEB(3*NATOMS),COMA(3),COMB(3)
162: DOUBLE PRECISION ANGLES(NROTATIONS,3), DISTSAVE, RMATSAVE(3,3), WORSTRAD, DIST2SAVE158: DOUBLE PRECISION ANGLES(NROTATIONS,3), DISTSAVE, RMATSAVE(3,3), WORSTRAD, DIST2SAVE
163: INTEGER J,J1,J2,M1,M2,IND2,NROT,NDUMMY,INVERT,PATOMS159: INTEGER J,J1,J2,M1,M2,IND2,NROT,NDUMMY,INVERT,PATOMS
164: INTEGER SAVEPERM(NCOORDS), KEEPPERM(NCOORDS)160: INTEGER SAVEPERM(NATOMS), KEEPPERM(NATOMS)
165:  
166: NATOMS=NCOORDS 
167: 161: 
168: ! Checking keywords are set properly162: ! Checking keywords are set properly
169: CALL CHECKKEYWORDS()163: CALL CHECKKEYWORDS()
 164: 
 165: ! Allocate arrays
170: CALL SETNATOMS(NATOMS)166: CALL SETNATOMS(NATOMS)
171: 167: 
 168: ! Setting keywords for fastoverlap use of minpermdist, will be reset when exiting program
 169: PERMINVOPTSAVE = PERMINVOPT
 170: NOINVERSIONSAVE = NOINVERSION
 171: PERMINVOPT = .FALSE.
 172: NOINVERSION = .TRUE.
 173: 
172: ! If the kernel width is not specified by the user, we choose a value appropriate to this system (1/3 of the average174: ! If the kernel width is not specified by the user, we choose a value appropriate to this system (1/3 of the average
173: ! nearest-neighbour separation in COORDSA)175: ! nearest-neighbour separation in COORDSA)
174: IF (KWIDTH .LE. 0.0D0) CALL CHOOSE_KWIDTH(NATOMS, COORDSA, COORDSB, KWIDTH, DEBUG)176: IF (KWIDTH .LE. 0.0D0) CALL CHOOSE_KWIDTH(NATOMS, COORDSA, COORDSB, KWIDTH, DEBUG)
175: 177: 
176: ! Centering COORDSA and COORDSB on the origin178: ! Centering COORDSA and COORDSB on the origin
177: COMA = 0.D0179: COMA = 0.D0
178: COMB = 0.D0180: COMB = 0.D0
179: DO J=1,NATOMS181: DO J=1,NATOMS
180:     COMA = COMA + COORDSA(3*J-2:3*J)182:     COMA = COMA + COORDSA(3*J-2:3*J)
181:     COMB = COMB + COORDSB(3*J-2:3*J)183:     COMB = COMB + COORDSB(3*J-2:3*J)
182: ENDDO184: ENDDO
183: COMA = COMA/NATOMS185: COMA = COMA/NATOMS
184: COMB = COMB/NATOMS186: COMB = COMB/NATOMS
185: DO J=1,NATOMS187: DO J=1,NATOMS
186:     COORDSA(3*J-2:3*J) = COORDSA(3*J-2:3*J) - COMA188:     COORDSA(3*J-2:3*J) = COORDSA(3*J-2:3*J) - COMA
187:     COORDSB(3*J-2:3*J) = COORDSB(3*J-2:3*J) - COMB189:     COORDSB(3*J-2:3*J) = COORDSB(3*J-2:3*J) - COMB
188: ENDDO190: ENDDO
189: 191: 
 192: 
190: ! Calculating overlap integral separately for each permutation group193: ! Calculating overlap integral separately for each permutation group
191: IMML = CMPLX(0.D0,0.D0,REAL64)194: IMML = CMPLX(0.D0, 0.D0, REAL64)
192: NDUMMY=1195: NDUMMY=1
193: DO J1=1,NPERMGROUP196: DO J1=1,NPERMGROUP
194:     PATOMS=INT(NPERMSIZE(J1),4)197:     PATOMS=INT(NPERMSIZE(J1),4)
195:     DO J2=1,PATOMS198:     DO J2=1,PATOMS
196:         IND2 = PERMGROUP(NDUMMY+J2-1)199:         IND2 = PERMGROUP(NDUMMY+J2-1)
197:         SAVEA(3*J2-2:3*J2)=COORDSA(3*IND2-2:3*IND2)200:         SAVEA(3*J2-2:3*J2)=COORDSA(3*IND2-2:3*IND2)
198:         SAVEB(3*J2-2:3*J2)=COORDSB(3*IND2-2:3*IND2)201:         SAVEB(3*J2-2:3*J2)=COORDSB(3*IND2-2:3*IND2)
199:     ENDDO202:     ENDDO
200:     CALL FOURIERCOEFFS(SAVEB,SAVEA,PATOMS,L,KWIDTH,PIMML,YMLB,YMLA)203:     CALL FOURIERCOEFFS(SAVEB,SAVEA,PATOMS,L,KWIDTH,PIMML,YMLB,YMLA)
201:     DO J=0,L204:     DO J=0,L
207:     ENDDO210:     ENDDO
208:     NDUMMY=NDUMMY+NPERMSIZE(J1)211:     NDUMMY=NDUMMY+NPERMSIZE(J1)
209: ENDDO212: ENDDO
210: 213: 
211: SAVEA(1:3*NATOMS) = COORDSA(1:3*NATOMS)214: SAVEA(1:3*NATOMS) = COORDSA(1:3*NATOMS)
212: SAVEB(1:3*NATOMS) = COORDSB(1:3*NATOMS)215: SAVEB(1:3*NATOMS) = COORDSB(1:3*NATOMS)
213: 216: 
214: NROT = NROTATIONS217: NROT = NROTATIONS
215: CALL ALIGNCOEFFS(SAVEB,SAVEA,NATOMS,IMML,L,DEBUG,DISTSAVE,DIST2SAVE,RMATSAVE,NROT,ANGLES)218: CALL ALIGNCOEFFS(SAVEB,SAVEA,NATOMS,IMML,L,DEBUG,DISTSAVE,DIST2SAVE,RMATSAVE,NROT,ANGLES)
216: 219: 
217: IF (PERMINVOPT.AND.(.NOT.NOINVERSION)) THEN220: IF (PERMINVOPTSAVE.AND.(.NOT.(CHRMMT.OR.AMBERT.OR.AMBER12T))) THEN 
218:     IF (DEBUG) WRITE(MYUNIT,'(A)') 'fastoverlap> inverting geometry for comparison with target'221:     IF (DEBUG) WRITE(MYUNIT,'(A)') 'fastoverlap> inverting geometry for comparison with target'
219:     ! Saving non inverted configuration222:     ! Saving non inverted configuration
220:     XBESTASAVE(1:3*NATOMS) = SAVEA(1:3*NATOMS)223:     XBESTASAVE(1:3*NATOMS) = SAVEA(1:3*NATOMS)
221: 224: 
222:     ! Calculating overlap integral for inverted configuration225:     ! Calculating overlap integral for inverted configuration
223:     NDUMMY=1226:     NDUMMY=1
224:     DO J1=1,NPERMGROUP227:     DO J1=1,NPERMGROUP
225:         PATOMS=INT(NPERMSIZE(J1),4)228:         PATOMS=INT(NPERMSIZE(J1),4)
226:         DO J2=1,PATOMS229:         DO J2=1,PATOMS
227:             IND2 = PERMGROUP(NDUMMY+J2-1)230:             IND2 = PERMGROUP(NDUMMY+J2-1)
262:     DIST2 = DIST2SAVE265:     DIST2 = DIST2SAVE
263:     RMATBEST = RMATSAVE266:     RMATBEST = RMATSAVE
264: ENDIF267: ENDIF
265: 268: 
266: IF (DEBUG) THEN269: IF (DEBUG) THEN
267:     WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> overall best distance=', distance270:     WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> overall best distance=', distance
268:     WRITE(MYUNIT,'(A)') 'fastoverlap> overall best rotation matrix:'271:     WRITE(MYUNIT,'(A)') 'fastoverlap> overall best rotation matrix:'
269:     WRITE(MYUNIT, '(3F20.10)') RMATBEST(1:3,1:3)272:     WRITE(MYUNIT, '(3F20.10)') RMATBEST(1:3,1:3)
270: ENDIF273: ENDIF
271: 274: 
 275: PERMINVOPT = PERMINVOPTSAVE
 276: NOINVERSION = NOINVERSIONSAVE
 277: 
272: END SUBROUTINE FOM_ALIGN_CLUSTERS278: END SUBROUTINE FOM_ALIGN_CLUSTERS
273: 279: 
274: SUBROUTINE ALIGNHARM(COORDSB, COORDSA, NCOORDS, DEBUG, N, L, HWIDTH, KWIDTH, DISTANCE, DIST2, RMATBEST, NROTATIONS)280: SUBROUTINE ALIGNHARM(COORDSB, COORDSA, NATOMS, DEBUG, N, L, HWIDTH, KWIDTH, DISTANCE, DIST2, RMATBEST, NROTATIONS)
275: !  COORDSA becomes the optimal alignment of the optimal permutation(-inversion)281: !  COORDSA becomes the optimal alignment of the optimal permutation(-inversion)
276: !  isomer. DISTANCE is the residual square distance for the best alignment with282: !  isomer. DISTANCE is the residual square distance for the best alignment with 
277: !  respect to permutation(-inversion)s as well as orientation and centre of mass.283: !  respect to permutation(-inversion)s as well as orientation and centre of mass.
278: !  COORDSA and COORDSB are both centred on the ORIGIN284: !  COORDSA and COORDSB are both centred on the ORIGIN
279: 285: 
280: !  RMATBEST gives the optimal rotation matrix286: !  RMATBEST gives the optimal rotation matrix
281: 287: 
282: !  KWIDTH is the width of the Gaussian kernels that are centered on each of the288: !  KWIDTH is the width of the Gaussian kernels that are centered on each of the
283: !  atomic coordinates, whose overlap integral is maximised to find the optimal289: !  atomic coordinates, whose overlap integral is maximised to find the optimal
284: !  rotations290: !  rotations
285: !  L is the maximum angular momentum degree up to which the SO(3) coefficients291: !  L is the maximum angular momentum degree up to which the SO(3) coefficients 
286: !  are calculated number of coefficients that will be calculated = 1/3 (L+1)(2L+1)(2L+3)292: !  are calculated number of coefficients that will be calculated = 1/3 (L+1)(2L+1)(2L+3)
287: 293: 
288: !  HWIDTH is the lengthscale of the Quantum Harmonic Oscillator Basis294: !  HWIDTH is the lengthscale of the Quantum Harmonic Oscillator Basis
289: !  N is the maximum order of the Quantum Harmonic Oscillator basis295: !  N is the maximum order of the Quantum Harmonic Oscillator basis
290: 296: 
291: !  Number of Calculations for SO(3) calculations ~ O(1/3 (L+1)(2L+1)(2L+3) * NATOMS**2)297: !  Number of Calculations for SO(3) calculations ~ O(1/3 (L+1)(2L+1)(2L+3) * NATOMS**2)
292: USE FASTOVERLAPUTILS, ONLY : SETNATOMS298: 
 299: USE COMMONS, ONLY: BESTPERM, PERMOPT, PERMINVOPT, NOINVERSION, CHRMMT, AMBERT, AMBER12T
 300: USE FASTOVERLAPUTILS, ONLY: SETNATOMS
293: IMPLICIT NONE301: IMPLICIT NONE
294: 302: 
295: INTEGER, INTENT(IN) :: NCOORDS, N, L303: INTEGER, INTENT(IN) :: NATOMS, N, L
296: INTEGER, INTENT(IN) :: NROTATIONS304: INTEGER, INTENT(IN) :: NROTATIONS
297: LOGICAL, INTENT(IN) :: DEBUG305: LOGICAL, INTENT(IN) :: DEBUG
298: DOUBLE PRECISION, INTENT(IN) :: HWIDTH, KWIDTH306: DOUBLE PRECISION, INTENT(IN) :: HWIDTH, KWIDTH
299: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS)307: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NATOMS), COORDSB(3*NATOMS)
300: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2, RMATBEST(3,3)308: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2, RMATBEST(3,3)
301: 309: 
302: COMPLEX(KIND=REAL64) PIMML(-L:L,-L:L,0:L)310: COMPLEX(KIND=REAL64) PIMML(-L:L,-L:L,0:L)
303: COMPLEX(KIND=REAL64) IMML(-L:L,-L:L,0:L), YMLA(-L:L,0:L,NCOORDS), YMLB(-L:L,0:L,NCOORDS)311: COMPLEX(KIND=REAL64) IMML(-L:L,-L:L,0:L), YMLA(-L:L,0:L,NATOMS), YMLB(-L:L,0:L,NATOMS)
304: COMPLEX(KIND=REAL64) COEFFSA(0:N,-L:L,0:L,NPERMGROUP), COEFFSB(0:N,-L:L,0:L,NPERMGROUP)312: COMPLEX(KIND=REAL64) COEFFSA(0:N,-L:L,0:L,NPERMGROUP), COEFFSB(0:N,-L:L,0:L,NPERMGROUP)
305: 313: 
306: DOUBLE PRECISION SAVEA(3*NCOORDS),SAVEB(3*NCOORDS)314: DOUBLE PRECISION SAVEA(3*NATOMS),SAVEB(3*NATOMS)
307: DOUBLE PRECISION ANGLES(NROTATIONS,3), DISTSAVE, RMATSAVE(3,3), WORSTRAD, DIST2SAVE315: DOUBLE PRECISION ANGLES(NROTATIONS,3), DISTSAVE, RMATSAVE(3,3), WORSTRAD, DIST2SAVE
308: INTEGER J,J1,J2,M1,M2,IND2,NROT,NDUMMY,INVERT,PATOMS316: INTEGER J,J1,J2,M1,M2,IND2,NROT,NDUMMY,INVERT,PATOMS
309: INTEGER SAVEPERM(NCOORDS), KEEPPERM(NCOORDS)317: INTEGER SAVEPERM(NATOMS), KEEPPERM(NATOMS)
 318: 
310: 319: 
311: NATOMS=NCOORDS 
312: ! Checking keywords are set properly320: ! Checking keywords are set properly
313: CALL CHECKKEYWORDS()321: CALL CHECKKEYWORDS()
 322: 
 323: ! Allocate arrays
314: CALL SETNATOMS(NATOMS)324: CALL SETNATOMS(NATOMS)
315: 325: 
 326: ! Setting keywords for fastoverlap use of minpermdist, will be reset when exiting program
 327: PERMINVOPTSAVE = PERMINVOPT
 328: NOINVERSIONSAVE = NOINVERSION
 329: PERMINVOPT = .FALSE.
 330: NOINVERSION = .TRUE.
 331: 
316: ! Calculating overlap integral separately for each permutation group332: ! Calculating overlap integral separately for each permutation group
317: IMML = CMPLX(0.D0,0.D0,REAL64)333: IMML = CMPLX(0.D0, 0.D0, REAL64)
318: NDUMMY=1334: NDUMMY=1
319: DO J1=1,NPERMGROUP335: DO J1=1,NPERMGROUP
320:     PATOMS=INT(NPERMSIZE(J1),4)336:     PATOMS=INT(NPERMSIZE(J1),4)
321:     DO J2=1,PATOMS337:     DO J2=1,PATOMS
322:         IND2 = PERMGROUP(NDUMMY+J2-1)338:         IND2 = PERMGROUP(NDUMMY+J2-1)
323:         SAVEA(3*J2-2:3*J2)=COORDSA(3*IND2-2:3*IND2)339:         SAVEA(3*J2-2:3*J2)=COORDSA(3*IND2-2:3*IND2)
324:         SAVEB(3*J2-2:3*J2)=COORDSB(3*IND2-2:3*IND2)340:         SAVEB(3*J2-2:3*J2)=COORDSB(3*IND2-2:3*IND2)
325:     ENDDO341:     ENDDO
326:     CALL HARMONICCOEFFS(SAVEA, PATOMS, COEFFSA(:,:,:,J1), N, L, HWIDTH, KWIDTH)342:     CALL HARMONICCOEFFS(SAVEA, PATOMS, COEFFSA(:,:,:,J1), N, L, HWIDTH, KWIDTH)
327:     CALL HARMONICCOEFFS(SAVEB, PATOMS, COEFFSB(:,:,:,J1), N, L, HWIDTH, KWIDTH)343:     CALL HARMONICCOEFFS(SAVEB, PATOMS, COEFFSB(:,:,:,J1), N, L, HWIDTH, KWIDTH)
332:             IMML(M1,M2,J) = IMML(M1,M2,J) + PIMML(M1,M2,J)348:             IMML(M1,M2,J) = IMML(M1,M2,J) + PIMML(M1,M2,J)
333:             ENDDO349:             ENDDO
334:         ENDDO350:         ENDDO
335:     ENDDO351:     ENDDO
336:     NDUMMY=NDUMMY+NPERMSIZE(J1)352:     NDUMMY=NDUMMY+NPERMSIZE(J1)
337: ENDDO353: ENDDO
338: 354: 
339: NROT = NROTATIONS355: NROT = NROTATIONS
340: CALL ALIGNCOEFFS(SAVEB,SAVEA,NATOMS,IMML,L,DEBUG,DISTSAVE,DIST2SAVE,RMATSAVE,NROT,ANGLES)356: CALL ALIGNCOEFFS(SAVEB,SAVEA,NATOMS,IMML,L,DEBUG,DISTSAVE,DIST2SAVE,RMATSAVE,NROT,ANGLES)
341: 357: 
342: IF (PERMINVOPT.AND.(.NOT.(NOINVERSION))) THEN358: IF (PERMINVOPTSAVE.AND.(.NOT.(CHRMMT.OR.AMBERT.OR.AMBER12T))) THEN 
343:     IF (DEBUG) WRITE(MYUNIT,'(A)') 'fastoverlap> inverting geometry for comparison with target'359:     IF (DEBUG) WRITE(MYUNIT,'(A)') 'fastoverlap> inverting geometry for comparison with target'
344:     ! Saving non inverted configuration360:     ! Saving non inverted configuration
345:     XBESTASAVE(1:3*NATOMS) = SAVEA(1:3*NATOMS)361:     XBESTASAVE(1:3*NATOMS) = SAVEA(1:3*NATOMS)
346:     KEEPPERM(1:NATOMS) = BESTPERM(1:NATOMS)362:     KEEPPERM(1:NATOMS) = BESTPERM(1:NATOMS)
347:     SAVEA = -COORDSA(1:3*NATOMS)363:     SAVEA = -COORDSA(1:3*NATOMS)
348:     NROT = NROTATIONS364:     NROT = NROTATIONS
349: 365: 
350:     ! Recalculating Fourier Coefficients for inverted COORDSA366:     ! Recalculating Fourier Coefficients for inverted COORDSA
351:     IMML = CMPLX(0.D0,0.D0,REAL64)367:     IMML = CMPLX(0.D0, 0.D0, REAL64)
352:     NDUMMY=1368:     NDUMMY=1
353:     DO J1=1,NPERMGROUP369:     DO J1=1,NPERMGROUP
354:         DO J=0,L370:         DO J=0,L
355:             COEFFSA(:,:,J,J1) = COEFFSA(:,:,J,J1) * (-1)**(J)371:             COEFFSA(:,:,J,J1) = COEFFSA(:,:,J,J1) * (-1)**(J)
356:         ENDDO372:         ENDDO
357:         CALL DOTHARMONICCOEFFS(COEFFSB(:,:,:,J1), COEFFSA(:,:,:,J1), N, L, PIMML)373:         CALL DOTHARMONICCOEFFS(COEFFSB(:,:,:,J1), COEFFSA(:,:,:,J1), N, L, PIMML)
358:         DO J=0,L374:         DO J=0,L
359:             DO M2=-J,J375:             DO M2=-J,J
360:                 DO M1=-J,J376:                 DO M1=-J,J
361:                 IMML(M1,M2,J) = IMML(M1,M2,J) + PIMML(M1,M2,J)377:                 IMML(M1,M2,J) = IMML(M1,M2,J) + PIMML(M1,M2,J)
362:                 ENDDO378:                 ENDDO
363:             ENDDO379:             ENDDO
364:         ENDDO380:         ENDDO
365:         NDUMMY=NDUMMY+NPERMSIZE(J1)381:         NDUMMY=NDUMMY+NPERMSIZE(J1)
366:     ENDDO382:     ENDDO
367:     CALL ALIGNCOEFFS(SAVEB,SAVEA,NATOMS,IMML,L,DEBUG,DISTANCE,DIST2,RMATBEST,NROT,ANGLES)383:     CALL ALIGNCOEFFS(SAVEB,SAVEA,NATOMS,IMML,L,DEBUG,DISTANCE,DIST2,RMATBEST,NROT,ANGLES)
368: 384:     
369:     IF (DISTANCE.LT.DISTSAVE) THEN385:     IF (DISTANCE.LT.DISTSAVE) THEN
370:         IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') &386:         IF (DEBUG) WRITE(MYUNIT,'(A,G20.10)') &
371:     &   'fastoverlap> inversion found better alignment, distance=', distance387:     &   'fastoverlap> inversion found better alignment, distance=', distance
372:         COORDSA(1:3*NATOMS) = SAVEA(1:3*NATOMS)388:         COORDSA(1:3*NATOMS) = SAVEA(1:3*NATOMS)
373:         RMATBEST = RMATSAVE389:         RMATBEST = RMATSAVE
374:     ELSE390:     ELSE
375:         COORDSA(1:3*NATOMS) = XBESTASAVE(1:3*NATOMS)391:         COORDSA(1:3*NATOMS) = XBESTASAVE(1:3*NATOMS)
376:         DISTANCE = DISTSAVE392:         DISTANCE = DISTSAVE
377:         DIST2 = DIST2SAVE393:         DIST2 = DIST2SAVE
378:         RMATBEST = RMATSAVE394:         RMATBEST = RMATSAVE
384:     DIST2 = DIST2SAVE400:     DIST2 = DIST2SAVE
385:     RMATBEST = RMATSAVE401:     RMATBEST = RMATSAVE
386: ENDIF402: ENDIF
387: 403: 
388: IF (DEBUG) THEN404: IF (DEBUG) THEN
389:     WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> overall best distance=', distance405:     WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> overall best distance=', distance
390:     WRITE(MYUNIT,'(A)') 'fastoverlap> overall best rotation matrix:'406:     WRITE(MYUNIT,'(A)') 'fastoverlap> overall best rotation matrix:'
391:     WRITE(MYUNIT, '(3F20.10)') RMATBEST(1:3,1:3)407:     WRITE(MYUNIT, '(3F20.10)') RMATBEST(1:3,1:3)
392: ENDIF408: ENDIF
393: 409: 
 410: PERMINVOPT = PERMINVOPTSAVE
 411: NOINVERSION = NOINVERSIONSAVE
 412: 
394: END SUBROUTINE ALIGNHARM413: END SUBROUTINE ALIGNHARM
395: 414: 
396: SUBROUTINE ALIGNCOEFFS(COORDSB,COORDSA,NCOORDS,IMML,L,DEBUG,DISTANCE,DIST2,RMATBEST,NROTATIONS,ANGLES)415: SUBROUTINE ALIGNCOEFFS(COORDSB,COORDSA,NATOMS,IMML,L,DEBUG,DISTANCE,DIST2,RMATBEST,NROTATIONS,ANGLES)
397: ! Aligns two structures, specified by COORDSA and COORDSB, aligns COORDSA so it most416: ! Aligns two structures, specified by COORDSA and COORDSB, aligns COORDSA so it most
398: ! closely matches COORDSB.417: ! closely matches COORDSB. 
399: ! Assumes that COORDSA and COORDSB are both centered on their Centers of Mass418: ! Assumes that COORDSA and COORDSB are both centered on their Centers of Mass
400: ! Uses precalculated Fourier Coefficients, IMML419: ! Uses precalculated Fourier Coefficients, IMML
401: ! Uses minpermdist to refine alignment420: ! Uses minpermdist to refine alignment
402: 421: 
403: ! Low-level routine, better to use ALIGN or ALIGNHARM422: ! Low-level routine, better to use ALIGN or ALIGNHARM
 423: USE COMMONS, ONLY: PERMOPT, PERMINVOPT
404: 424: 
405: USE ALIGNUTILS, ONLY : ITERATIVEALIGN 
406: USE FASTOVERLAPUTILS, ONLY : SETNATOMS 
407: IMPLICIT NONE425: IMPLICIT NONE
408: 426: 
409: INTEGER, INTENT(IN) :: NCOORDS, L427: INTEGER, INTENT(IN) :: NATOMS, L
410: INTEGER, INTENT(INOUT) :: NROTATIONS428: INTEGER, INTENT(INOUT) :: NROTATIONS
411: LOGICAL, INTENT(IN) :: DEBUG429: LOGICAL, INTENT(IN) :: DEBUG
412: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS)430: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NATOMS), COORDSB(3*NATOMS)
413: DOUBLE PRECISION, INTENT(OUT) :: ANGLES(NROTATIONS,3)431: DOUBLE PRECISION, INTENT(OUT) :: ANGLES(NROTATIONS,3)
414: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2, RMATBEST(3,3)432: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2, RMATBEST(3,3)
415: COMPLEX(KIND=REAL64), INTENT(IN) :: IMML(-L:L,-L:L,0:L)433: COMPLEX(KIND=REAL64), INTENT(IN) :: IMML(-L:L,-L:L,0:L)
416: 434: 
417: COMPLEX(KIND=REAL64) ILMM(0:L,0:2*L,0:2*L)435: COMPLEX(KIND=REAL64) ILMM(0:L,0:2*L,0:2*L)
418: DOUBLE PRECISION OVERLAP(2*L+2,2*L+2,2*L+2)436: DOUBLE PRECISION OVERLAP(2*L+2,2*L+2,2*L+2)
419: DOUBLE PRECISION AMPLITUDES(NROTATIONS), BESTDIST, RMATSAVE(3,3), RMAT(3,3), WORSTRAD, DISP(3)437: DOUBLE PRECISION AMPLITUDES(NROTATIONS), BESTDIST, RMATSAVE(3,3), RMAT(3,3), WORSTRAD
420: INTEGER J, J1, PERMBEST(NCOORDS)438: INTEGER J, J1
421: 439: 
422: NATOMS=NCOORDS 
423: CALL SETNATOMS(NATOMS) 
424: 440: 
425: CALL CALCOVERLAP(IMML, OVERLAP, L, ILMM)441: CALL CALCOVERLAP(IMML, OVERLAP, L, ILMM)
426: CALL FINDROTATIONS(OVERLAP, L, ANGLES, AMPLITUDES, NROTATIONS, DEBUG)442: CALL FINDROTATIONS(OVERLAP, L, ANGLES, AMPLITUDES, NROTATIONS, DEBUG)
427: IF (DEBUG) WRITE(MYUNIT,'(A,I3,A)') 'fastoverlap> found ', NROTATIONS, ' candidate rotations'443: IF (DEBUG) WRITE(MYUNIT,'(A,I3,A)') 'fastoverlap> found ', NROTATIONS, ' candidate rotations'
428: 444: 
429: 445: 
430: BESTDIST = HUGE(BESTDIST)446: BESTDIST = HUGE(BESTDIST)
431: DUMMYB(:) = COORDSB(:3*NATOMS)447: DUMMYB(:) = COORDSB(:3*NATOMS)
432: 448: 
433: DO J=1,NROTATIONS449: DO J=1,NROTATIONS
437:         DUMMYA(J1*3-2:J1*3) = MATMUL(RMATSAVE, COORDSA(J1*3-2:J1*3))453:         DUMMYA(J1*3-2:J1*3) = MATMUL(RMATSAVE, COORDSA(J1*3-2:J1*3))
438:     ENDDO454:     ENDDO
439: 455: 
440:     IF (DEBUG) THEN456:     IF (DEBUG) THEN
441:         WRITE(MYUNIT,'(A,I3,A)') 'fastoverlap> testing rotation', J, ' with Euler angles:'457:         WRITE(MYUNIT,'(A,I3,A)') 'fastoverlap> testing rotation', J, ' with Euler angles:'
442:         WRITE(MYUNIT, '(3F20.10)') ANGLES(J,:)458:         WRITE(MYUNIT, '(3F20.10)') ANGLES(J,:)
443:         WRITE(MYUNIT,'(A)') 'fastoverlap> testing rotation matrix:'459:         WRITE(MYUNIT,'(A)') 'fastoverlap> testing rotation matrix:'
444:         WRITE(MYUNIT, '(3F20.10)') RMATSAVE(1:3,1:3)460:         WRITE(MYUNIT, '(3F20.10)') RMATSAVE(1:3,1:3)
445:     ENDIF461:     ENDIF
446: 462: 
447:     ! CALL MINPERMDIST(DUMMYB,DUMMYA,NATOMS,DEBUG,0.D0,0.D0,0.D0,.FALSE.,.FALSE.,DISTANCE,DIST2,.FALSE.,RMAT)463:     CALL MINPERMDIST(DUMMYB,DUMMYA,NATOMS,DEBUG,0.D0,0.D0,0.D0,.FALSE.,.FALSE.,DISTANCE,DIST2,.FALSE.,RMAT)
448:     CALL ITERATIVEALIGN(DUMMYB,DUMMYA,NATOMS,DEBUG,0.D0,0.D0,0.D0,.FALSE.,DIST2,DISTANCE,RMAT,DISP,PERMBEST)464:     IF (DISTANCE.LT.BESTDIST) THEN
449:         IF (DISTANCE.LT.BESTDIST) THEN 
450:         BESTDIST = DISTANCE465:         BESTDIST = DISTANCE
451:         XBESTA(1:3*NATOMS) = DUMMYA(1:3*NATOMS)466:         XBESTA(1:3*NATOMS) = DUMMYA(1:3*NATOMS)
452:         RMATBEST = MATMUL(RMAT,RMATSAVE)467:         RMATBEST = MATMUL(RMAT,RMATSAVE)
453: 468: 
454:         IF (DEBUG) THEN469:         IF (DEBUG) THEN
455:             WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> new best alignment distance=', BESTDIST470:             WRITE(MYUNIT,'(A,G20.10)') 'fastoverlap> new best alignment distance=', BESTDIST
456:             WRITE(MYUNIT,'(A)') 'fastoverlap> new best rotation matrix:'471:             WRITE(MYUNIT,'(A)') 'fastoverlap> new best rotation matrix:'
457:             WRITE(MYUNIT, '(3F20.10)') RMATBEST(1:3,1:3)472:             WRITE(MYUNIT, '(3F20.10)') RMATBEST(1:3,1:3)
458:         END IF473:         END IF
459: 474: 
491:     RET(I) = R0SIGMA / SQRT(1.D0+2.D0*I) * RET(I-1)506:     RET(I) = R0SIGMA / SQRT(1.D0+2.D0*I) * RET(I-1)
492: ENDDO507: ENDDO
493: 508: 
494: END SUBROUTINE HARMONIC0L509: END SUBROUTINE HARMONIC0L
495: 510: 
496: SUBROUTINE HARMONICNL(N,L,RJ,SIGMA,R0,RET)511: SUBROUTINE HARMONICNL(N,L,RJ,SIGMA,R0,RET)
497: 512: 
498: !513: !
499: ! Calculates the value of the overlap integral up to N and L514: ! Calculates the value of the overlap integral up to N and L
500: !515: !
501: ! 4\pi \int_0^{\infty} g_{nl}(r)\exp{\left(-\frac{r^2+{r^p_j}^2}{2\sigma^2}\right)}516: ! 4\pi \int_0^{\infty} g_{nl}(r)\exp{\left(-\frac{r^2+{r^p_j}^2}{2\sigma^2}\right)} 
502: ! i_l \left( \frac{r r^p_{j}}{\sigma^2} \right) r^2\; \mathrm{d}r517: ! i_l \left( \frac{r r^p_{j}}{\sigma^2} \right) r^2\; \mathrm{d}r
503: !518: !
504: ! N is the maximum quantum number of the Harmonic basis to calculate up to519: ! N is the maximum quantum number of the Harmonic basis to calculate up to
505: ! L is the maximum angular moment number to calculate520: ! L is the maximum angular moment number to calculate
506: ! SIGMA is the width of the Gaussian Kernels521: ! SIGMA is the width of the Gaussian Kernels
507: ! R0 is the length scale of the Harmonic Basis522: ! R0 is the length scale of the Harmonic Basis
508: ! RET is the matrix of calculate values of the overlap integral523: ! RET is the matrix of calculate values of the overlap integral
509: !524: !
510: 525: 
511: IMPLICIT NONE526: IMPLICIT NONE
561: INTEGER J, M, INDM1, INDM0, INDM2576: INTEGER J, M, INDM1, INDM0, INDM2
562: DOUBLE PRECISION THETA, PHI, Z, FACTORIALS(0:2*L), SQRTZ, SQRTMJ577: DOUBLE PRECISION THETA, PHI, Z, FACTORIALS(0:2*L), SQRTZ, SQRTMJ
563: COMPLEX(KIND=REAL64) EXPIM(-L:L)578: COMPLEX(KIND=REAL64) EXPIM(-L:L)
564: 579: 
565: R = (COORD(1)**2+COORD(2)**2+COORD(3)**2)**0.5580: R = (COORD(1)**2+COORD(2)**2+COORD(3)**2)**0.5
566: PHI = ATAN2(COORD(2), COORD(1))581: PHI = ATAN2(COORD(2), COORD(1))
567: Z = COORD(3)/R582: Z = COORD(3)/R
568: SQRTZ = SQRT(1.D0-Z**2)583: SQRTZ = SQRT(1.D0-Z**2)
569: 584: 
570: !Calculating Associate Legendre Function585: !Calculating Associate Legendre Function
571: YML = CMPLX(0.D0,0.D0, REAL64)586: YML = CMPLX(0.D0, 0.D0, REAL64)
572: YML(0,0) = (4*PI)**(-0.5)587: YML(0,0) = (4*PI)**(-0.5)
573: 588: 
574: ! Initialising Recurrence for Associated Legendre Polynomials589: ! Initialising Recurrence for Associated Legendre Polynomials
575: ! Calculating normalised Legendre Polynomials for better numerical stability590: ! Calculating normalised Legendre Polynomials for better numerical stability
576: ! Pnorm^m_l = \sqrt{(l-m)!/(l+m)!} P^m_l591: ! Pnorm^m_l = \sqrt{(l-m)!/(l+m)!} P^m_l
577: DO J=0, L-1592: DO J=0, L-1
578:     YML(J+1,J+1) = - SQRT((2.D0*J+1.D0)/(2.D0*J+2.D0)) * SQRTZ* YML(J,J)593:     YML(J+1,J+1) = - SQRT((2.D0*J+1.D0)/(2.D0*J+2.D0)) * SQRTZ* YML(J,J)
579:     ! Calculating first recurrence term594:     ! Calculating first recurrence term
580:     YML(J, J+1) = -SQRT(2.D0*(J+1))*Z/SQRTZ * YML(J+1, J+1)595:     YML(J, J+1) = -SQRT(2.D0*(J+1))*Z/SQRTZ * YML(J+1, J+1)
581: ENDDO596: ENDDO
618: 633: 
619: INTEGER J, M, INDM1, INDM0, INDM2, ISIG634: INTEGER J, M, INDM1, INDM0, INDM2, ISIG
620: DOUBLE PRECISION THETA, PHI, Z, FACTORIALS(0:2*L), SQRTZ, SQRTMJ, PLM(0:L), IPN(0:L), FACT635: DOUBLE PRECISION THETA, PHI, Z, FACTORIALS(0:2*L), SQRTZ, SQRTMJ, PLM(0:L), IPN(0:L), FACT
621: COMPLEX(KIND=REAL64) EXPIM(-L:L)636: COMPLEX(KIND=REAL64) EXPIM(-L:L)
622: 637: 
623: R = (COORD(1)**2+COORD(2)**2+COORD(3)**2)**0.5638: R = (COORD(1)**2+COORD(2)**2+COORD(3)**2)**0.5
624: PHI = ATAN2(COORD(2), COORD(1))639: PHI = ATAN2(COORD(2), COORD(1))
625: Z = COORD(3)/R640: Z = COORD(3)/R
626: 641: 
627: !Calculating Associate Legendre Function642: !Calculating Associate Legendre Function
628: YML = CMPLX(0.D0,0.D0, REAL64)643: YML = CMPLX(0.D0, 0.D0, REAL64)
629: YML(0,0) = (4*PI)**(-0.5)644: YML(0,0) = (4*PI)**(-0.5)
630: 645: 
631: FACT = (2*PI)**(-0.5)646: FACT = (2*PI)**(-0.5)
632: 647: 
633: DO J=0, L648: DO J=0, L
634:     ! Calculate Normalised Legendre Polynomial649:     ! Calculate Normalised Legendre Polynomial
635:     CALL XDNRMP(J,0,J,Z,1,PLM(0:J),IPN(0:J),ISIG)650:     CALL XDNRMP(J,0,J,Z,1,PLM(0:J),IPN(0:J),ISIG)
636:     YML(0:J,J) = PLM(0:J) * FACT651:     YML(0:J,J) = PLM(0:J) * FACT
637:     DO M=1,J652:     DO M=1,J
638:         YML(-M,J) = YML(M,J)653:         YML(-M,J) = YML(M,J)
648: ! Calculate Spherical Harmonics663: ! Calculate Spherical Harmonics
649: DO J=1,L664: DO J=1,L
650:     DO M=-J,J665:     DO M=-J,J
651:         INDM0 = MODULO(M, 2*L+1)666:         INDM0 = MODULO(M, 2*L+1)
652:         YML(M,J) = EXPIM(M)*YML(M,J) !* SQRT((2.D0*J+1.D0))667:         YML(M,J) = EXPIM(M)*YML(M,J) !* SQRT((2.D0*J+1.D0))
653:     ENDDO668:     ENDDO
654: ENDDO669: ENDDO
655: 670: 
656: END SUBROUTINE RYML671: END SUBROUTINE RYML
657: 672: 
658: SUBROUTINE HARMONICCOEFFS(COORDS, NCOORDS, CNML, N, L, HWIDTH, KWIDTH)673: SUBROUTINE HARMONICCOEFFS(COORDS, NATOMS, CNML, N, L, HWIDTH, KWIDTH)
659: 674: 
660: !675: !
661: ! For a set of Gaussian Kernels of width KWIDTH at COORDS,676: ! For a set of Gaussian Kernels of width KWIDTH at COORDS, 
662: ! this will calculate the coefficients of the isotropic quantum harmonic basis677: ! this will calculate the coefficients of the isotropic quantum harmonic basis
663: ! cnlm with length scale HWIDTH up to N and L.678: ! cnlm with length scale HWIDTH up to N and L.
664: !679: !
665: 680: 
666: IMPLICIT NONE681: IMPLICIT NONE
667: 682: 
668: INTEGER, INTENT(IN) :: NCOORDS, N, L683: INTEGER, INTENT(IN) :: NATOMS, N, L
669: DOUBLE PRECISION, INTENT(IN) :: COORDS(3*NCOORDS), HWIDTH, KWIDTH684: DOUBLE PRECISION, INTENT(IN) :: COORDS(3*NATOMS), HWIDTH, KWIDTH
670: COMPLEX(KIND=REAL64), INTENT(OUT) :: CNML(0:N,-L:L,0:L)685: COMPLEX(KIND=REAL64), INTENT(OUT) :: CNML(0:N,-L:L,0:L)
671: 686: 
672: COMPLEX(KIND=REAL64) :: YML(-L:L,0:L)687: COMPLEX(KIND=REAL64) :: YML(-L:L,0:L)
673: DOUBLE PRECISION HARMCOEFFS(0:2*N+L,0:N,0:L), DNL(0:N,0:L+2*N), RJ688: DOUBLE PRECISION HARMCOEFFS(0:2*N+L,0:N,0:L), DNL(0:N,0:L+2*N), RJ
674: INTEGER I,J,K,SI,M,INDM, S689: INTEGER I,J,K,SI,M,INDM, S
675: 690: 
676: CNML = CMPLX(0.D0,0.D0,REAL64)691: CNML = CMPLX(0.D0, 0.D0, REAL64)
677: 692: 
678: DO K=1,NCOORDS693: DO K=1,NATOMS
679:     CALL RYML(COORDS(3*K-2:3*K), RJ, YML, L)694:     CALL RYML(COORDS(3*K-2:3*K), RJ, YML, L)
680:     CALL HARMONICNL(N,L+2*N,RJ,KWIDTH,HWIDTH,DNL)695:     CALL HARMONICNL(N,L+2*N,RJ,KWIDTH,HWIDTH,DNL)
681:     DO J=0,L696:     DO J=0,L
682:         DO M=-J,J697:         DO M=-J,J
683:             INDM = MODULO(M,2*L+1)698:             INDM = MODULO(M,2*L+1)
684:             DO I=0,N699:             DO I=0,N
685:                 CNML(I,M,J) = CNML(I,M,J) + DNL(I,J) * CONJG(YML(M,J))700:                 CNML(I,M,J) = CNML(I,M,J) + DNL(I,J) * CONJG(YML(M,J))
686:             ENDDO701:             ENDDO
687:         ENDDO702:         ENDDO
688:     ENDDO703:     ENDDO
689: ENDDO704: ENDDO
690: 705: 
691: END SUBROUTINE HARMONICCOEFFS706: END SUBROUTINE HARMONICCOEFFS
692: 707: 
693: SUBROUTINE HARMONICCOEFFSPERM(COORDS, NCOORDS, CNML, N, L, HWIDTH, KWIDTH, NPERMGROUPS)708: SUBROUTINE HARMONICCOEFFSPERM(COORDS, NATOMS, CNML, N, L, HWIDTH, KWIDTH, NPERMGROUP)
694: 709: 
695: !710: !
696: ! For a set of Gaussian Kernels of width KWIDTH at COORDS,711: ! For a set of Gaussian Kernels of width KWIDTH at COORDS, 
697: ! this will calculate the coefficients of the isotropic quantum harmonic basis712: ! this will calculate the coefficients of the isotropic quantum harmonic basis
698: ! cnlm with length scale HWIDTH up to N and L.713: ! cnlm with length scale HWIDTH up to N and L.
699: ! Returns coefficients of the different permutations groups714: ! Returns coefficients of the different permutations groups
700: !715: !
701: 716: 
702: IMPLICIT NONE717: IMPLICIT NONE
703: 718: 
704: INTEGER, INTENT(IN) :: NCOORDS, N, L, NPERMGROUPS719: INTEGER, INTENT(IN) :: NATOMS, N, L, NPERMGROUP
705: DOUBLE PRECISION, INTENT(IN) :: COORDS(3*NCOORDS), HWIDTH, KWIDTH720: DOUBLE PRECISION, INTENT(IN) :: COORDS(3*NATOMS), HWIDTH, KWIDTH
706: COMPLEX(KIND=REAL64), INTENT(OUT) :: CNML(0:N,-L:L,0:L,1:NPERMGROUPS)721: COMPLEX(KIND=REAL64), INTENT(OUT) :: CNML(0:N,-L:L,0:L,1:NPERMGROUP)
707: 722: 
708: DOUBLE PRECISION DUMMY(3*NCOORDS)723: DOUBLE PRECISION DUMMY(3*NATOMS)
709: INTEGER J1, J2, IND2, NDUMMY, PATOMS724: INTEGER J1, J2, IND2, NDUMMY, PATOMS
710: 725: 
711: IF (NPERMGROUP.NE.NPERMGROUPS) THEN 
712:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
713:     STOP 
714: ENDIF 
715:  
716: ! Calculating overlap integral separately for each permutation group726: ! Calculating overlap integral separately for each permutation group
717: NDUMMY=1727: NDUMMY=1
718: DO J1=1,NPERMGROUP728: DO J1=1,NPERMGROUP
719:     PATOMS=NPERMSIZE(J1)729:     PATOMS=NPERMSIZE(J1)
720:     DO J2=1,PATOMS730:     DO J2=1,PATOMS
721:         IND2 = PERMGROUP(NDUMMY+J2-1)731:         IND2 = PERMGROUP(NDUMMY+J2-1)
722:         DUMMY(3*J2-2:3*J2)=COORDS(3*IND2-2:3*IND2)732:         DUMMY(3*J2-2:3*J2)=COORDS(3*IND2-2:3*IND2)
723:     ENDDO733:     ENDDO
724:     CALL HARMONICCOEFFS(DUMMY, PATOMS, CNML(:,:,:,J1), N, L, HWIDTH, KWIDTH)734:     CALL HARMONICCOEFFS(DUMMY, PATOMS, CNML(:,:,:,J1), N, L, HWIDTH, KWIDTH)
725:     NDUMMY=NDUMMY+PATOMS735:     NDUMMY=NDUMMY+PATOMS
726: ENDDO736: ENDDO
727: 737: 
728: END SUBROUTINE HARMONICCOEFFSPERM738: END SUBROUTINE HARMONICCOEFFSPERM
729: 739: 
730: SUBROUTINE HARMONICCOEFFSMULTI(COORDSLIST,NCOORDS,NLIST,CNMLLIST,N,L,HWIDTH,KWIDTH,NPERMGROUPS)740: SUBROUTINE HARMONICCOEFFSMULTI(COORDSLIST,NATOMS,NLIST,CNMLLIST,N,L,HWIDTH,KWIDTH,NPERMGROUP)
731: 741: 
732: IMPLICIT NONE742: IMPLICIT NONE
733: 743: 
734: INTEGER, INTENT(IN) :: NCOORDS, NLIST, N, L, NPERMGROUPS744: INTEGER, INTENT(IN) :: NATOMS, NLIST, N, L, NPERMGROUP
735: DOUBLE PRECISION, INTENT(IN) :: COORDSLIST(3*NCOORDS, NLIST), HWIDTH, KWIDTH745: DOUBLE PRECISION, INTENT(IN) :: COORDSLIST(3*NATOMS, NLIST), HWIDTH, KWIDTH
736: COMPLEX(KIND=REAL64), INTENT(OUT) :: CNMLLIST(0:N,-L:L,0:L,1:NPERMGROUPS, NLIST)746: COMPLEX(KIND=REAL64), INTENT(OUT) :: CNMLLIST(0:N,-L:L,0:L,1:NPERMGROUP, NLIST)
737: 747: 
738: INTEGER I748: INTEGER I
739: 749: 
740: !write(*,*) NCOORDS, NLIST, N, L, NPERMGROUPS750: !write(*,*) NATOMS, NLIST, N, L, NPERMGROUP
741: !WRITE(*,*) SHAPE(CNMLLIST), SHAPE(COORDSLIST)751: !WRITE(*,*) SHAPE(CNMLLIST), SHAPE(COORDSLIST)
742: 752: 
743: IF (NPERMGROUP.NE.NPERMGROUPS) THEN 
744:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
745:     STOP 
746: ENDIF 
747:  
748: DO I=1,NLIST753: DO I=1,NLIST
749:     CALL HARMONICCOEFFSPERM(COORDSLIST(:,I),NCOORDS,CNMLLIST(:,:,:,:,I),N,L,HWIDTH,KWIDTH,NPERMGROUP)754:     CALL HARMONICCOEFFSPERM(COORDSLIST(:,I),NATOMS,CNMLLIST(:,:,:,:,I),N,L,HWIDTH,KWIDTH,NPERMGROUP)
750: ENDDO755: ENDDO
751: 756: 
752: END SUBROUTINE HARMONICCOEFFSMULTI757: END SUBROUTINE HARMONICCOEFFSMULTI
753: 758: 
754: SUBROUTINE DOTHARMONICCOEFFS(C1NML, C2NML, N, L, IMML)759: SUBROUTINE DOTHARMONICCOEFFS(C1NML, C2NML, N, L, IMML)
755: 760: 
756: IMPLICIT NONE761: IMPLICIT NONE
757: 762: 
758: INTEGER, INTENT(IN) :: N, L763: INTEGER, INTENT(IN) :: N, L
759: COMPLEX(KIND=REAL64), INTENT(IN) :: C1NML(0:N,-L:L,0:L), C2NML(0:N,-L:L,0:L)764: COMPLEX(KIND=REAL64), INTENT(IN) :: C1NML(0:N,-L:L,0:L), C2NML(0:N,-L:L,0:L)
760: COMPLEX(KIND=REAL64), INTENT(OUT) :: IMML(-L:L,-L:L,0:L)765: COMPLEX(KIND=REAL64), INTENT(OUT) :: IMML(-L:L,-L:L,0:L)
761: 766: 
762: INTEGER I, J, M1, M2, INDM1, INDM2767: INTEGER I, J, M1, M2, INDM1, INDM2
763: 768: 
764: IMML = CMPLX(0.D0,0.D0,REAL64)769: IMML = CMPLX(0.D0, 0.D0, REAL64)
765: 770: 
766: DO J=0,L771: DO J=0,L
767:     DO M2=-J,J772:     DO M2=-J,J
768:         DO M1=-J,J773:         DO M1=-J,J
769:             DO I=0,N774:             DO I=0,N
770:                 IMML(M1,M2,J) = IMML(M1,M2,J) + CONJG(C1NML(I,M1,J))*C2NML(I,M2,J)775:                 IMML(M1,M2,J) = IMML(M1,M2,J) + CONJG(C1NML(I,M1,J))*C2NML(I,M2,J)
771:             ENDDO776:             ENDDO
772:         ENDDO777:         ENDDO
773:     ENDDO778:     ENDDO
774: ENDDO779: ENDDO
775: 780: 
776: END SUBROUTINE DOTHARMONICCOEFFS781: END SUBROUTINE DOTHARMONICCOEFFS
777: 782: 
778: SUBROUTINE DOTHARMONICCOEFFSPERM(C1NML, C2NML, N, L, IMML, NPERMGROUPS)783: SUBROUTINE DOTHARMONICCOEFFSPERM(C1NML, C2NML, N, L, IMML, NPERMGROUP)
779: 784: 
780: IMPLICIT NONE785: IMPLICIT NONE
781: 786: 
782: INTEGER, INTENT(IN) :: N, L, NPERMGROUPS787: INTEGER, INTENT(IN) :: N, L, NPERMGROUP
783: COMPLEX(KIND=REAL64), INTENT(IN) :: C1NML(0:N,-L:L,0:L,NPERMGROUPS), C2NML(0:N,-L:L,0:L,NPERMGROUPS)788: COMPLEX(KIND=REAL64), INTENT(IN) :: C1NML(0:N,-L:L,0:L,NPERMGROUP), C2NML(0:N,-L:L,0:L,NPERMGROUP)
784: COMPLEX(KIND=REAL64), INTENT(OUT) :: IMML(-L:L,-L:L,0:L)789: COMPLEX(KIND=REAL64), INTENT(OUT) :: IMML(-L:L,-L:L,0:L)
785: 790: 
786: INTEGER I, J, M1, M2, K, INDM1, INDM2791: INTEGER I, J, M1, M2, K, INDM1, INDM2
787: 792: 
788: IF (NPERMGROUP.NE.NPERMGROUPS) THEN793: IMML = CMPLX(0.D0, 0.D0, REAL64)
789:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
790:     STOP 
791: ENDIF 
792: IMML = CMPLX(0.D0,0.D0,REAL64) 
793: 794: 
794: DO K=1,NPERMGROUP795: DO K=1,NPERMGROUP
795:     DO J=0,L796:     DO J=0,L
796:         DO M2=-J,J797:         DO M2=-J,J
797:             DO M1=-J,J798:             DO M1=-J,J
798:                 DO I=0,N799:                 DO I=0,N
799:                     IMML(M1,M2,J) = IMML(M1,M2,J) + CONJG(C1NML(I,M1,J,K))*C2NML(I,M2,J,K)800:                     IMML(M1,M2,J) = IMML(M1,M2,J) + CONJG(C1NML(I,M1,J,K))*C2NML(I,M2,J,K)
800:                 ENDDO801:                 ENDDO
801:             ENDDO802:             ENDDO
802:         ENDDO803:         ENDDO
803:     ENDDO804:     ENDDO
804: ENDDO805: ENDDO
805: 806: 
806: END SUBROUTINE DOTHARMONICCOEFFSPERM807: END SUBROUTINE DOTHARMONICCOEFFSPERM
807: 808: 
808: SUBROUTINE CALCSIMILARITY(C1NML, C2NML, N, L, NPERMGROUPS, NORM, MAXOVER)809: SUBROUTINE CALCSIMILARITY(C1NML, C2NML, N, L, NPERMGROUP, NORM, MAXOVER)
809: 810: 
810: IMPLICIT NONE811: IMPLICIT NONE
811: 812: 
812: INTEGER, INTENT(IN) :: N, L, NPERMGROUPS813: INTEGER, INTENT(IN) :: N, L, NPERMGROUP
813: COMPLEX(KIND=REAL64), INTENT(IN) :: C1NML(0:N,-L:L,0:L,NPERMGROUPS), C2NML(0:N,-L:L,0:L,NPERMGROUPS)814: COMPLEX(KIND=REAL64), INTENT(IN) :: C1NML(0:N,-L:L,0:L,NPERMGROUP), C2NML(0:N,-L:L,0:L,NPERMGROUP)
814: DOUBLE PRECISION, INTENT(OUT) :: NORM, MAXOVER815: DOUBLE PRECISION, INTENT(OUT) :: NORM, MAXOVER
815: 816: 
816: COMPLEX(KIND=REAL64) IMML(-L:L,-L:L,0:L), ILMM(0:L,0:2*L,0:2*L)817: COMPLEX(KIND=REAL64) IMML(-L:L,-L:L,0:L), ILMM(0:L,0:2*L,0:2*L)
817: DOUBLE PRECISION OVERLAP(2*L+2,2*L+2,2*L+2)818: DOUBLE PRECISION OVERLAP(2*L+2,2*L+2,2*L+2)
818: 819: 
819: INTEGER J,M1,M2820: INTEGER J,M1,M2
820: 821: 
821: IF (NPERMGROUP.NE.NPERMGROUPS) THEN 
822:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
823:     STOP 
824: ENDIF 
825:  
826: CALL DOTHARMONICCOEFFSPERM(C1NML, C2NML, N, L, IMML, NPERMGROUP)822: CALL DOTHARMONICCOEFFSPERM(C1NML, C2NML, N, L, IMML, NPERMGROUP)
827: 823: 
828: ! Calculated average overlap824: ! Calculated average overlap
829: DO J=0,L825: DO J=0,L
830:     DO M2=-J,J826:     DO M2=-J,J
831:         DO M1=-J,J827:         DO M1=-J,J
832:             NORM = NORM + REAL(IMML(M1,M2,J),8)**2 + AIMAG(IMML(M1,M2,J))**2828:             NORM = NORM + REAL(IMML(M1,M2,J),8)**2 + AIMAG(IMML(M1,M2,J))**2
833:         ENDDO829:         ENDDO
834:     ENDDO830:     ENDDO
835: ENDDO831: ENDDO
836: 832: 
837: ! Calculate max overlap833: ! Calculate max overlap
838: CALL CALCOVERLAP(IMML, OVERLAP, L, ILMM)834: CALL CALCOVERLAP(IMML, OVERLAP, L, ILMM)
839: MAXOVER = MAXVAL(OVERLAP)835: MAXOVER = MAXVAL(OVERLAP)
840: 836: 
841: END SUBROUTINE CALCSIMILARITY837: END SUBROUTINE CALCSIMILARITY
842: 838: 
843: SUBROUTINE CALCSIMILARITIES(C1NMLLIST,N1LIST,C2NMLLIST,N2LIST,N,L,NPERMGROUPS,NORMS,MAXOVERS,SYM)839: SUBROUTINE CALCSIMILARITIES(C1NMLLIST,N1LIST,C2NMLLIST,N2LIST,N,L,NPERMGROUP,NORMS,MAXOVERS,SYM)
844: 840: 
845: IMPLICIT NONE841: IMPLICIT NONE
846: INTEGER, INTENT(IN) :: N1LIST, N2LIST, N, L, NPERMGROUPS842: INTEGER, INTENT(IN) :: N1LIST, N2LIST, N, L, NPERMGROUP
847: COMPLEX(KIND=REAL64), INTENT(IN) :: C1NMLLIST(0:N,-L:L,0:L,NPERMGROUPS,N1LIST), &843: COMPLEX(KIND=REAL64), INTENT(IN) :: C1NMLLIST(0:N,-L:L,0:L,NPERMGROUP,N1LIST), &
848:     & C2NMLLIST(0:N,-L:L,0:L,NPERMGROUPS,N2LIST)844:     & C2NMLLIST(0:N,-L:L,0:L,NPERMGROUP,N2LIST)
849: LOGICAL, INTENT(IN) :: SYM845: LOGICAL, INTENT(IN) :: SYM
850: DOUBLE PRECISION, INTENT(OUT) :: NORMS(N1LIST,N2LIST), MAXOVERS(N1LIST,N2LIST)846: DOUBLE PRECISION, INTENT(OUT) :: NORMS(N1LIST,N2LIST), MAXOVERS(N1LIST,N2LIST)
851: 847: 
852: INTEGER I1, I2848: INTEGER I1, I2
853: 849: 
854: IF (NPERMGROUP.NE.NPERMGROUPS) THEN 
855:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
856:     STOP 
857: ENDIF 
858:  
859: IF (SYM) THEN850: IF (SYM) THEN
860:     ! if C1NMLLIST == C2NMLLIST then only need to calculate half the values851:     ! if C1NMLLIST == C2NMLLIST then only need to calculate half the values
861:     DO I1=1,N1LIST852:     DO I1=1,N1LIST
862:         DO I2=I1,N1LIST853:         DO I2=I1,N1LIST
863:             CALL CALCSIMILARITY(C1NMLLIST(:,:,:,:,I1), C2NMLLIST(:,:,:,:,I2), N, L, NPERMGROUP, &854:             CALL CALCSIMILARITY(C1NMLLIST(:,:,:,:,I1), C2NMLLIST(:,:,:,:,I2), N, L, NPERMGROUP, &
864:                 & NORMS(I1,I2), MAXOVERS(I1,I2))855:                 & NORMS(I1,I2), MAXOVERS(I1,I2))
865:             NORMS(I2,I1) = NORMS(I1,I2)856:             NORMS(I2,I1) = NORMS(I1,I2)
866:             MAXOVERS(I2,I1) = MAXOVERS(I1,I2)857:             MAXOVERS(I2,I1) = MAXOVERS(I1,I2)
867:         ENDDO858:         ENDDO
868:     ENDDO859:     ENDDO
871:     DO I1=1,N1LIST862:     DO I1=1,N1LIST
872:         DO I2=1,N1LIST863:         DO I2=1,N1LIST
873:             CALL CALCSIMILARITY(C1NMLLIST(:,:,:,:,I1), C2NMLLIST(:,:,:,:,I2), N, L, NPERMGROUP, &864:             CALL CALCSIMILARITY(C1NMLLIST(:,:,:,:,I1), C2NMLLIST(:,:,:,:,I2), N, L, NPERMGROUP, &
874:                 & NORMS(I1,I2), MAXOVERS(I1,I2))865:                 & NORMS(I1,I2), MAXOVERS(I1,I2))
875:         ENDDO866:         ENDDO
876:     ENDDO867:     ENDDO
877: ENDIF868: ENDIF
878: 869: 
879: END SUBROUTINE CALCSIMILARITIES870: END SUBROUTINE CALCSIMILARITIES
880: 871: 
881: SUBROUTINE CALCOVERLAPMATRICES(COORDSLIST,NCOORDS,NLIST,N,L,HWIDTH,KWIDTH,NORMS,MAXOVERS)872: SUBROUTINE CALCOVERLAPMATRICES(COORDSLIST,NATOMS,NLIST,N,L,HWIDTH,KWIDTH,NORMS,MAXOVERS)
882: 873: 
883: IMPLICIT NONE874: IMPLICIT NONE
884: 875: 
885: INTEGER, INTENT(IN) :: NCOORDS, NLIST, N, L876: INTEGER, INTENT(IN) :: NATOMS, NLIST, N, L
886: DOUBLE PRECISION, INTENT(IN) :: COORDSLIST(3*NCOORDS, NLIST), HWIDTH, KWIDTH877: DOUBLE PRECISION, INTENT(IN) :: COORDSLIST(3*NATOMS, NLIST), HWIDTH, KWIDTH
887: DOUBLE PRECISION, INTENT(OUT) :: NORMS(NLIST,NLIST), MAXOVERS(NLIST,NLIST)878: DOUBLE PRECISION, INTENT(OUT) :: NORMS(NLIST,NLIST), MAXOVERS(NLIST,NLIST)
888: 879: 
889: COMPLEX(KIND=REAL64) CNMLLIST(0:N,-L:L,0:L,1:NPERMGROUP, NLIST)880: COMPLEX(KIND=REAL64) CNMLLIST(0:N,-L:L,0:L,1:NPERMGROUP, NLIST)
890: 881: 
891: CALL HARMONICCOEFFSMULTI(COORDSLIST,NCOORDS,NLIST,CNMLLIST,N,L,HWIDTH,KWIDTH,NPERMGROUP)882: CALL HARMONICCOEFFSMULTI(COORDSLIST,NATOMS,NLIST,CNMLLIST,N,L,HWIDTH,KWIDTH,NPERMGROUP)
892: CALL CALCSIMILARITIES(CNMLLIST,NLIST,CNMLLIST,NLIST,N,L,NPERMGROUP,NORMS,MAXOVERS,.TRUE.)883: CALL CALCSIMILARITIES(CNMLLIST,NLIST,CNMLLIST,NLIST,N,L,NPERMGROUP,NORMS,MAXOVERS,.TRUE.)
893: 884: 
894: END SUBROUTINE CALCOVERLAPMATRICES885: END SUBROUTINE CALCOVERLAPMATRICES
895: 886: 
896: SUBROUTINE FOURIERCOEFFS(COORDSB, COORDSA, NCOORDS, L, KWIDTH, IMML, YMLB, YMLA)887: SUBROUTINE FOURIERCOEFFS(COORDSB, COORDSA, NATOMS, L, KWIDTH, IMML, YMLB, YMLA)
897: !888: !
898: ! Calculates S03 Coefficients of the overlap integral of two structures889: ! Calculates S03 Coefficients of the overlap integral of two structures
899: ! does this calculation by direct calculation of the overlap between every pair890: ! does this calculation by direct calculation of the overlap between every pair
900: ! of atoms, slower than the Harmonic basis, but slightly more accurate.891: ! of atoms, slower than the Harmonic basis, but slightly more accurate.
901: !892: !
902: 893: 
903: IMPLICIT NONE894: IMPLICIT NONE
904: INTEGER, INTENT(IN) :: NCOORDS, L895: INTEGER, INTENT(IN) :: NATOMS, L
905: DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS), KWIDTH896: DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NATOMS), COORDSB(3*NATOMS), KWIDTH
906: COMPLEX(KIND=REAL64), INTENT(OUT) :: IMML(-L:L,-L:L,0:L)897: COMPLEX(KIND=REAL64), INTENT(OUT) :: IMML(-L:L,-L:L,0:L)
907: 898: 
908: COMPLEX(KIND=REAL64), INTENT(OUT) ::  YMLA(-L:L,0:L,NCOORDS), YMLB(-L:L,0:L,NCOORDS)899: COMPLEX(KIND=REAL64), INTENT(OUT) ::  YMLA(-L:L,0:L,NATOMS), YMLB(-L:L,0:L,NATOMS)
909: DOUBLE PRECISION RA(NCOORDS), RB(NCOORDS), IL(0:L), R1R2, EXPRA(NCOORDS), EXPRB(NCOORDS), FACT, TMP900: DOUBLE PRECISION RA(NATOMS), RB(NATOMS), IL(0:L), R1R2, EXPRA(NATOMS), EXPRB(NATOMS), FACT, TMP
910: 901: 
911: INTEGER IA,IB,I,J,K,M1,M2,INDM1,INDM2902: INTEGER IA,IB,I,J,K,M1,M2,INDM1,INDM2
912: 903: 
913: YMLA = CMPLX(0.D0,0.D0,REAL64)904: YMLA = CMPLX(0.D0, 0.D0, REAL64)
914: YMLB = CMPLX(0.D0,0.D0,REAL64)905: YMLB = CMPLX(0.D0, 0.D0, REAL64)
915: ! Precalculate some values906: ! Precalculate some values
916: DO I=1,NCOORDS907: DO I=1,NATOMS
917:     CALL RYML(COORDSA(3*I-2:3*I), RA(I), YMLA(:,:,I), L)908:     CALL RYML(COORDSA(3*I-2:3*I), RA(I), YMLA(:,:,I), L)
918:     CALL RYML(COORDSB(3*I-2:3*I), RB(I), YMLB(:,:,I), L)909:     CALL RYML(COORDSB(3*I-2:3*I), RB(I), YMLB(:,:,I), L)
919:     EXPRA(I) = EXP(-0.25D0 * RA(I)**2 / KWIDTH**2)910:     EXPRA(I) = EXP(-0.25D0 * RA(I)**2 / KWIDTH**2)
920:     EXPRB(I) = EXP(-0.25D0 * RB(I)**2 / KWIDTH**2)911:     EXPRB(I) = EXP(-0.25D0 * RB(I)**2 / KWIDTH**2)
921: ENDDO912: ENDDO
922: 913: 
923: FACT = 4.D0 * PI**2.5 * KWIDTH**3914: FACT = 4.D0 * PI**2.5 * KWIDTH**3
924: 915: 
925: IMML = CMPLX(0.D0,0.D0,REAL64)916: IMML = CMPLX(0.D0, 0.D0, REAL64)
926: DO IA=1,NCOORDS917: DO IA=1,NATOMS
927:     DO IB=1,NCOORDS918:     DO IB=1,NATOMS
928:         ! Don't calculate cross terms for points separated by 4 kwidths to speed up calculation919:         ! Don't calculate cross terms for points separated by 4 kwidths to speed up calculation
929:         IF (ABS(RA(IA)-RB(IB)).LT.(4*KWIDTH)) THEN920:         IF (ABS(RA(IA)-RB(IB)).LT.(4*KWIDTH)) THEN
930:             R1R2 = 0.5D0 * RA(IA)*RB(IB)/KWIDTH**2921:             R1R2 = 0.5D0 * RA(IA)*RB(IB)/KWIDTH**2
931:             CALL SPHI(L, R1R2, K, IL)922:             CALL SPHI(L, R1R2, K, IL)
932:             TMP = FACT*EXPRA(IA)*EXPRB(IB)!*SQRT(PI/2/R1R2)923:             TMP = FACT*EXPRA(IA)*EXPRB(IB)!*SQRT(PI/2/R1R2)
933:             DO J=0,L924:             DO J=0,L
934:                 DO M2=-L,L925:                 DO M2=-L,L
935:                     DO M1=-L,L926:                     DO M1=-L,L
936:                         IMML(M1,M2,J) = IMML(M1,M2,J) + IL(J)*YMLB(M1,J,IB)*CONJG(YMLA(M2,J,IA))*TMP927:                         IMML(M1,M2,J) = IMML(M1,M2,J) + IL(J)*YMLB(M1,J,IB)*CONJG(YMLA(M2,J,IA))*TMP
937:                     ENDDO928:                     ENDDO
1064:   ROTM (3,1) =          SINB * COSA1055:   ROTM (3,1) =          SINB * COSA
1065:   ROTM (1,2) = - COSG * COSB * SINA  -  SING * COSA1056:   ROTM (1,2) = - COSG * COSB * SINA  -  SING * COSA
1066:   ROTM (2,2) = - SING * COSB * SINA  +  COSG * COSA1057:   ROTM (2,2) = - SING * COSB * SINA  +  COSG * COSA
1067:   ROTM (3,2) = -        SINB * SINA1058:   ROTM (3,2) = -        SINB * SINA
1068:   ROTM (1,3) = - COSG * SINB1059:   ROTM (1,3) = - COSG * SINB
1069:   ROTM (2,3) = - SING * SINB1060:   ROTM (2,3) = - SING * SINB
1070:   ROTM (3,3) =          COSB1061:   ROTM (3,3) =          COSB
1071: 1062: 
1072: END SUBROUTINE EULERINVM1063: END SUBROUTINE EULERINVM
1073: 1064: 
1074: SUBROUTINE CHOOSE_KWIDTH(NCOORDS, COORDSA, COORDSB, KWIDTH, DEBUG)1065: SUBROUTINE CHOOSE_KWIDTH(NATOMS, COORDSA, COORDSB, KWIDTH, DEBUG)
1075: ! Calculate a reasonable default kernel width for the current alignment problem.1066: ! Calculate a reasonable default kernel width for the current alignment problem.
1076: ! KWIDTH is set to 1/3 times the average nearest-neighbour separation in the two clusters.1067: ! KWIDTH is set to 1/3 times the average nearest-neighbour separation in the two clusters.
1077: ! For each atom in each structure, the closest other atom is identified. The distance to these closest atoms is averaged across1068: ! For each atom in each structure, the closest other atom is identified. The distance to these closest atoms is averaged across
1078: ! all atoms and both structures.1069: ! all atoms and both structures.
1079: 1070: 
1080: IMPLICIT NONE1071: IMPLICIT NONE
1081: 1072: 
1082: INTEGER, INTENT(IN)           :: NCOORDS1073: INTEGER, INTENT(IN)           :: NATOMS
1083: DOUBLE PRECISION, INTENT(IN)  :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS)1074: DOUBLE PRECISION, INTENT(IN)  :: COORDSA(3*NATOMS), COORDSB(3*NATOMS)
1084: DOUBLE PRECISION, INTENT(OUT) :: KWIDTH1075: DOUBLE PRECISION, INTENT(OUT) :: KWIDTH
1085: LOGICAL, INTENT(IN)           :: DEBUG1076: LOGICAL, INTENT(IN)           :: DEBUG
1086: 1077: 
1087: INTEGER          :: J1, J21078: INTEGER          :: J1, J2
1088: DOUBLE PRECISION :: DIST, MIN_DIST, SUM_MINDISTS1079: DOUBLE PRECISION :: DIST, MIN_DIST, SUM_MINDISTS
1089: 1080: 
1090: SUM_MINDISTS = 0.0D01081: SUM_MINDISTS = 0.0D0
1091: 1082: 
1092: ! Find average NN distance for structure A1083: ! Find average NN distance for structure A
1093: DO J1 = 1, NCOORDS  ! Find the nearest-neighbour distance of atom J11084: DO J1 = 1, NATOMS  ! Find the nearest-neighbour distance of atom J1
1094:    MIN_DIST = 1.0D101085:    MIN_DIST = 1.0D10
1095:    DO J2 = 1, NCOORDS  ! Check all the neighbours of J11086:    DO J2 = 1, NATOMS  ! Check all the neighbours of J1
1096:       IF (J1.EQ.J2) CYCLE1087:       IF (J1.EQ.J2) CYCLE
1097: 1088: 
1098:       DIST = SQRT((COORDSA(3*(J1-1)+1)-COORDSA(3*(J2-1)+1))**2 +   &1089:       DIST = SQRT((COORDSA(3*(J1-1)+1)-COORDSA(3*(J2-1)+1))**2 +   &
1099:     &             (COORDSA(3*(J1-1)+2)-COORDSA(3*(J2-1)+2))**2 +   &1090:     &             (COORDSA(3*(J1-1)+2)-COORDSA(3*(J2-1)+2))**2 +   &
1100:     &             (COORDSA(3*(J1-1)+3)-COORDSA(3*(J2-1)+3))**2)1091:     &             (COORDSA(3*(J1-1)+3)-COORDSA(3*(J2-1)+3))**2)
1101:       IF (DIST .LT. MIN_DIST) THEN1092:       IF (DIST .LT. MIN_DIST) THEN
1102:          MIN_DIST = DIST1093:          MIN_DIST = DIST
1103:       ENDIF1094:       ENDIF
1104:    ENDDO1095:    ENDDO
1105:    SUM_MINDISTS = SUM_MINDISTS + MIN_DIST1096:    SUM_MINDISTS = SUM_MINDISTS + MIN_DIST
1106: ENDDO1097: ENDDO
1107: 1098: 
1108: ! Find average NN distance for structure B1099: ! Find average NN distance for structure B
1109: DO J1 = 1, NCOORDS  ! Find the nearest-neighbour distance of atom J11100: DO J1 = 1, NATOMS  ! Find the nearest-neighbour distance of atom J1
1110:    MIN_DIST = 1.0D101101:    MIN_DIST = 1.0D10
1111:    DO J2 = 1, NCOORDS  ! Check all the neighbours of J11102:    DO J2 = 1, NATOMS  ! Check all the neighbours of J1
1112:       IF (J1.EQ.J2) CYCLE1103:       IF (J1.EQ.J2) CYCLE
1113: 1104: 
1114:       DIST = SQRT((COORDSB(3*(J1-1)+1)-COORDSB(3*(J2-1)+1))**2 +   &1105:       DIST = SQRT((COORDSB(3*(J1-1)+1)-COORDSB(3*(J2-1)+1))**2 +   &
1115:     &             (COORDSB(3*(J1-1)+2)-COORDSB(3*(J2-1)+2))**2 +   &1106:     &             (COORDSB(3*(J1-1)+2)-COORDSB(3*(J2-1)+2))**2 +   &
1116:     &             (COORDSB(3*(J1-1)+3)-COORDSB(3*(J2-1)+3))**2)1107:     &             (COORDSB(3*(J1-1)+3)-COORDSB(3*(J2-1)+3))**2)
1117:       IF (DIST .LT. MIN_DIST) THEN1108:       IF (DIST .LT. MIN_DIST) THEN
1118:          MIN_DIST = DIST1109:          MIN_DIST = DIST
1119:       ENDIF1110:       ENDIF
1120:    ENDDO1111:    ENDDO
1121:    SUM_MINDISTS = SUM_MINDISTS + MIN_DIST1112:    SUM_MINDISTS = SUM_MINDISTS + MIN_DIST
1122: ENDDO1113: ENDDO
1123: 1114: 
1124: KWIDTH = SUM_MINDISTS/(3*2*NCOORDS) ! 2*NCOORDS is the number of pairs over which we have averaged.1115: KWIDTH = SUM_MINDISTS/(3*2*NATOMS) ! 2*NATOMS is the number of pairs over which we have averaged.
1125:                                      ! Divide by 3 so that KWIDTH is 1/3 of the average separation1116:                                      ! Divide by 3 so that KWIDTH is 1/3 of the average separation
1126: 1117: 
1127: IF(DEBUG) write(*,*) "fastclusters> Determined an appropriate value for KWIDTH:", KWIDTH1118: IF(DEBUG) write(*,*) "fastclusters> Determined an appropriate value for KWIDTH:", KWIDTH
1128: 1119: 
1129: END SUBROUTINE CHOOSE_KWIDTH1120: END SUBROUTINE CHOOSE_KWIDTH
1130: 1121: 
1131: SUBROUTINE CHECKKEYWORDS()1122: SUBROUTINE SETCLUSTER()
1132: 1123: 
1133: USE COMMONS, ONLY : MYUNIT,NFREEZE,GEOMDIFFTOL,ORBITTOL,FREEZE,PULLT,TWOD,  &1124: USE COMMONS, ONLY : MYUNIT,NFREEZE,GEOMDIFFTOL,ORBITTOL,FREEZE,PULLT,TWOD,  &
1134:     &   EFIELDT,AMBERT,QCIAMBERT,AMBER12T,CHRMMT,STOCKT,CSMT,PERMDIST,      &1125:     &   EFIELDT,AMBERT,QCIAMBERT,AMBER12T,CHRMMT,STOCKT,CSMT,PERMDIST,      &
1135:     &   LOCALPERMDIST,LPERMDIST,OHCELLT,QCIPERMCHECK,PERMOPT,PERMINVOPT,    &1126:     &   LOCALPERMDIST,LPERMDIST,OHCELLT,QCIPERMCHECK,PERMOPT,PERMINVOPT,    &
1136:     &   NOINVERSION,GTHOMSONT,MKTRAPT,MULLERBROWNT,RIGID,OHCELLT1127:     &   NOINVERSION,GTHOMSONT,MKTRAPT,MULLERBROWNT,RIGID,OHCELLT
1137: 1128: 
1138: IMPLICIT NONE1129: IMPLICIT NONE
1139: 1130: 
1140: IF ((.NOT.ALLOCATED(PERMGROUP)).OR.(.NOT.ALLOCATED(NPERMSIZE))) THEN1131: MYUNIT = 6
1141:     WRITE(*,'(A)') 'ERROR - permutation arrays not set, use PERMOPT keyword'1132: NFREEZE = 0
1142:     STOP1133: GEOMDIFFTOL = 0.5D0
1143: ENDIF1134: ORBITTOL = 1.0D-3
 1135: 
 1136: FREEZE = .FALSE.
 1137: PULLT = .FALSE.
 1138: TWOD = .FALSE.
 1139: EFIELDT = .FALSE.
 1140: AMBERT = .FALSE.
 1141: QCIAMBERT = .FALSE.
 1142: AMBER12T = .FALSE.
 1143: CHRMMT = .FALSE.
 1144: STOCKT = .FALSE.
 1145: CSMT = .FALSE.
 1146: PERMDIST = .TRUE.
 1147: LOCALPERMDIST = .FALSE.
 1148: LPERMDIST = .FALSE.
 1149: QCIPERMCHECK = .FALSE.
 1150: PERMOPT = .TRUE.
 1151: PERMINVOPT = .TRUE.
 1152: NOINVERSION = .FALSE.
 1153: GTHOMSONT = .FALSE.
 1154: MKTRAPT = .FALSE.
 1155: MULLERBROWNT = .FALSE.
 1156: RIGID = .FALSE.
 1157: OHCELLT = .FALSE.
1144: 1158: 
1145: IF (OHCELLT) THEN1159: END SUBROUTINE SETCLUSTER
 1160: 
 1161: SUBROUTINE CHECKKEYWORDS()
 1162: 
 1163: USE COMMONS, ONLY : MYUNIT,NFREEZE,GEOMDIFFTOL,ORBITTOL,FREEZE,PULLT,TWOD,  &
 1164:     &   EFIELDT,AMBERT,QCIAMBERT,AMBER12T,CHRMMT,STOCKT,CSMT,PERMDIST,      &
 1165:     &   LOCALPERMDIST,LPERMDIST,OHCELLT,QCIPERMCHECK,PERMOPT,PERMINVOPT,    &
 1166:     &   NOINVERSION,GTHOMSONT,MKTRAPT,MULLERBROWNT,RIGID, OHCELLT
 1167: 
 1168: IMPLICIT NONE
 1169: 
 1170: IF(OHCELLT) THEN
1146:     WRITE(*,'(A)') 'ERROR - cluster fastoverlap not compatible with OHCELL keyword'1171:     WRITE(*,'(A)') 'ERROR - cluster fastoverlap not compatible with OHCELL keyword'
1147:     STOP1172:     STOP
1148: ENDIF1173: ENDIF
1149: 1174: 
1150: IF(STOCKT) THEN1175: IF(STOCKT) THEN
1151:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with STOCK keyword'1176:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with STOCK keyword'
1152:     STOP1177:     STOP
1153: ENDIF1178: ENDIF
1154: 1179: 
1155: IF(CSMT) THEN1180: IF(CSMT) THEN
1185: IF(GTHOMSONT) THEN1210: IF(GTHOMSONT) THEN
1186:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with GTHOMSON keyword'1211:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with GTHOMSON keyword'
1187:     STOP1212:     STOP
1188: ENDIF1213: ENDIF
1189: 1214: 
1190: IF(MKTRAPT) THEN1215: IF(MKTRAPT) THEN
1191:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with MKTRAP keyword'1216:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with MKTRAP keyword'
1192:     STOP1217:     STOP
1193: ENDIF1218: ENDIF
1194: 1219: 
 1220: IF(TWOD) THEN
 1221:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with TWOD keyword'
 1222:     STOP
 1223: ENDIF
 1224: 
 1225: 
1195: END SUBROUTINE CHECKKEYWORDS1226: END SUBROUTINE CHECKKEYWORDS
1196: 1227: 
1197: END MODULE CLUSTERFASTOVERLAP1228: END MODULE CLUSTERFASTOVERLAP
1198: 1229: 
1199: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1230: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1200:  
1201: ! INCLUDE "bulkmindist.f90" 
1202: ! INCLUDE "minpermdist.f90" 
1203: ! INCLUDE "minperm.f90" 
1204: ! INCLUDE "newmindist.f90" 
1205: ! INCLUDE "orient.f90" 
1206: ! INCLUDE "legendre.f90" 


r33355/fastutils.f90 2017-09-28 12:30:15.579924988 +0100 r33354/fastutils.f90 2017-09-28 12:30:17.367948527 +0100
  1: !    FASTOVERLAP  1: !    FASTOVERLAP
  2: !    Copyright (C) 2017  Matthew Griffiths  2: !    Copyright (C) 2017  Matthew Griffiths
  3: !  3: !    
  4: !    This program is free software; you can redistribute it and/or modify  4: !    This program is free software; you can redistribute it and/or modify
  5: !    it under the terms of the GNU General Public License as published by  5: !    it under the terms of the GNU General Public License as published by
  6: !    the Free Software Foundation; either version 2 of the License, or  6: !    the Free Software Foundation; either version 2 of the License, or
  7: !    (at your option) any later version.  7: !    (at your option) any later version.
  8: !  8: !    
  9: !    This program is distributed in the hope that it will be useful,  9: !    This program is distributed in the hope that it will be useful,
 10: !    but WITHOUT ANY WARRANTY; without even the implied warranty of 10: !    but WITHOUT ANY WARRANTY; without even the implied warranty of
 11: !    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 11: !    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 12: !    GNU General Public License for more details. 12: !    GNU General Public License for more details.
 13: ! 13: !    
 14: !    You should have received a copy of the GNU General Public License along 14: !    You should have received a copy of the GNU General Public License along
 15: !    with this program; if not, write to the Free Software Foundation, Inc., 15: !    with this program; if not, write to the Free Software Foundation, Inc.,
 16: !    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 16: !    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 17:  17: 
 18:  18: 
 19: !    Fortran 90/95 modules: 19: !    Fortran 90/95 modules:
 20: !      fastoverlaputils --- fshape,fspace,fvec,defaulttol,fsize,n,fastlen,defaultwidth,fjac,setindexes(),setfspace(),gaussian(),fcn(),fit(),findpeak(),findpeaks(),fft3d(),ifft3d(),fft1d(),ifft1d(). 20: !      fastoverlaputils --- fshape,fspace,fvec,defaulttol,fsize,n,fastlen,defaultwidth,fjac,setindexes(),setfspace(),gaussian(),fcn(),fit(),findpeak(),findpeaks(),fft3d(),ifft3d(),fft1d(),ifft1d().
 21: !    Functions: 21: !    Functions:
 22: !      rlegendrel0 = rlegendrel0(l,z) 22: !      rlegendrel0 = rlegendrel0(l,z)
 23: !      rlegendrem0 = rlegendrem0(m,l,z) 23: !      rlegendrem0 = rlegendrem0(m,l,z)
 33: !      enorm = enorm(x,n=len(x)) 33: !      enorm = enorm(x,n=len(x))
 34: !      enorm2 = enorm2(x,n=len(x)) 34: !      enorm2 = enorm2(x,n=len(x))
 35: !      lmpar(r,ipvt,diag,qtb,delta,par,x,sdiag,n=shape(r,1),ldr=shape(r,0)) 35: !      lmpar(r,ipvt,diag,qtb,delta,par,x,sdiag,n=shape(r,1),ldr=shape(r,0))
 36: !      qrsolv(r,ipvt,diag,qtb,x,sdiag,n=shape(r,1),ldr=shape(r,0)) 36: !      qrsolv(r,ipvt,diag,qtb,x,sdiag,n=shape(r,1),ldr=shape(r,0))
 37: !      qrfac(m,a,pivot,ipvt,rdiag,acnorm,n=shape(a,1),lda=shape(a,0),lipvt=len(ipvt)) 37: !      qrfac(m,a,pivot,ipvt,rdiag,acnorm,n=shape(a,1),lda=shape(a,0),lipvt=len(ipvt))
 38: !      xmed = median(x,n=len(x)) 38: !      xmed = median(x,n=len(x))
 39:  39: 
 40: MODULE FASTOVERLAPUTILS 40: MODULE FASTOVERLAPUTILS
 41:  41: 
 42: !*********************************************************************** 42: !***********************************************************************
 43: ! This module contains some subroutines that are useful for FASTOVERLAP 43: ! This module contains some subroutines that are useful for FASTOVERLAP 
 44: ! alignment for both periodic and isolated structures 44: ! alignment for both periodic and isolated structures
 45: !*********************************************************************** 45: !***********************************************************************
 46: ! Subroutines: 46: ! Subroutines:
 47: !     Permutations Routines 47: !     Permutations Routines
 48: !         SETPERM 48: !         SETPERM
  49: !         FINDBESTPERMUTATION
 49: !     Peakfinding subroutines: 50: !     Peakfinding subroutines:
 50: !         SETINDEXES 51: !         SETINDEXES
 51: !         SETFSPACE 52: !         SETFSPACE
 52: !         GAUSSIAN 53: !         GAUSSIAN
 53: !         FCN 54: !         FCN
 54: !         FIT 55: !         FIT
 55: !         FINDPEAK 56: !         FINDPEAK
 56: !         FINDPEAKS 57: !         FINDPEAKS
 57: !     FFT subroutines 58: !     FFT subroutines
 58: !         FFT3D 59: !         FFT3D
 59: !         IFFT3D 60: !         IFFT3D
 60: !         FFT1D 61: !         FFT1D
 61: !         IFFT1D 62: !         IFFT1D
 62: !*********************************************************************** 63: !***********************************************************************
 63: USE ALIGNUTILS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP, NATOMS, BESTPERM, NSETS, SETS, MYUNIT 64: USE COMMONS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP, NATOMS, BESTPERM, NSETS, SETS, MYUNIT
 64: USE FFTW3 65: USE FFTW3
 65: USE PREC, ONLY: INT64, REAL64 66: USE PREC, ONLY: INT32, INT64, REAL64
 66:  67: 
 67: IMPLICIT NONE 68: IMPLICIT NONE
 68:  69: 
 69: ! Variables and arrays needed for peakfinding 70: ! Variables and arrays needed for peakfinding
 70: INTEGER, PARAMETER :: DEFAULTWIDTH=2 71: INTEGER, PARAMETER :: DEFAULTWIDTH=2
 71: DOUBLE PRECISION, PARAMETER :: DEFAULTTOL=1.D-6 72: DOUBLE PRECISION, PARAMETER :: DEFAULTTOL=1.D-6
 72: INTEGER, SAVE :: FSIZE, FSHAPE(3) 73: INTEGER, SAVE :: FSIZE, FSHAPE(3)
 73: DOUBLE PRECISION, SAVE, ALLOCATABLE :: FSPACE(:,:,:),FSPACECOPY(:,:,:),GAUSARRAY(:,:,:),FVEC(:),FJAC(:,:) 74: DOUBLE PRECISION, SAVE, ALLOCATABLE :: FSPACE(:,:,:),FSPACECOPY(:,:,:),GAUSARRAY(:,:,:),FVEC(:),FJAC(:,:)
 74:  75: 
 75: !! Stuff for permutational alignment 76: ! Stuff for permutational alignment
 76: DOUBLE PRECISION, SAVE, ALLOCATABLE :: PDUMMYA(:), PDUMMYB(:), DUMMYA(:), DUMMYB(:), XBESTA(:), XBESTASAVE(:) 77: DOUBLE PRECISION, SAVE, ALLOCATABLE :: PDUMMYA(:), PDUMMYB(:), DUMMYA(:), DUMMYB(:), XBESTA(:), XBESTASAVE(:)
 77: INTEGER, SAVE, ALLOCATABLE :: NEWPERM(:), LPERM(:) 78: INTEGER, SAVE, ALLOCATABLE :: NEWPERM(:), LPERM(:)
 78:  79: 
 79: ! An array of the fastest length arrays on which to perform FFTs 80: ! An array of the fastest length arrays on which to perform FFTs
 80: INTEGER, SAVE :: FASTLEN(200) = (/1, 2, 3, 4, 5, 6, 8, 8, 9, 10, 12, 12, 15, & 81: INTEGER, SAVE :: FASTLEN(200) = (/1, 2, 3, 4, 5, 6, 8, 8, 9, 10, 12, 12, 15, &
 81:     15, 15, 16, 18, 18, 20, 20, 24, 24, 24, 24, 25, 27, 27, 30, 30, 30, 32, & 82:     15, 15, 16, 18, 18, 20, 20, 24, 24, 24, 24, 25, 27, 27, 30, 30, 30, 32, &
 82:     32, 36, 36, 36, 36, 40, 40, 40, 40, 45, 45, 45, 45, 45, 48, 48, 48, 50, & 83:     32, 36, 36, 36, 36, 40, 40, 40, 40, 45, 45, 45, 45, 45, 48, 48, 48, 50, &
 83:     50, 54, 54, 54, 54, 60, 60, 60, 60, 60, 60, 64, 64, 64, 64, 72, 72, 72, & 84:     50, 54, 54, 54, 54, 60, 60, 60, 60, 60, 60, 64, 64, 64, 64, 72, 72, 72, &
 84:     72, 72, 72, 72, 72, 75, 75, 75, 80, 80, 80, 80, 80, 81, 90, 90, 90, 90, & 85:     72, 72, 72, 72, 72, 75, 75, 75, 80, 80, 80, 80, 80, 81, 90, 90, 90, 90, &
 85:     90, 90, 90, 90, 90, 96, 96, 96, 96, 96, 96, 100, 100, 100, 100, 108, 108, & 86:     90, 90, 90, 90, 90, 96, 96, 96, 96, 96, 96, 100, 100, 100, 100, 108, 108, &
 92:     200, 200, 200, 200, 200, 200, 200, 200/) 93:     200, 200, 200, 200, 200, 200, 200, 200/)
 93:  94: 
 94: CONTAINS 95: CONTAINS
 95:  96: 
 96: SUBROUTINE SETNATOMS(NEWNATOMS) 97: SUBROUTINE SETNATOMS(NEWNATOMS)
 97: ! Checks if arrays need to be (re)allocated 98: ! Checks if arrays need to be (re)allocated
 98: IMPLICIT NONE 99: IMPLICIT NONE
 99: 100: 
100: INTEGER, INTENT(IN) :: NEWNATOMS101: INTEGER, INTENT(IN) :: NEWNATOMS
101: 102: 
102: IF((.NOT.ALLOCATED(PERMGROUP)).OR.(.NOT.ALLOCATED(NPERMSIZE))) THEN 
103:     WRITE(*,'(A)') 'ERROR - permutation arrays not set, use PERMOPT keyword' 
104:     STOP 
105: ENDIF 
106:  
107: IF(.NOT.(SIZE(PDUMMYA).EQ.(3*NEWNATOMS))) THEN103: IF(.NOT.(SIZE(PDUMMYA).EQ.(3*NEWNATOMS))) THEN
108:     IF(ALLOCATED(PDUMMYA)) THEN104:     IF(ALLOCATED(PDUMMYA)) THEN
109:         DEALLOCATE(PDUMMYA,PDUMMYB,DUMMYA,DUMMYB,XBESTA,XBESTASAVE)105:         DEALLOCATE(PDUMMYA,PDUMMYB,DUMMYA,DUMMYB,XBESTA,XBESTASAVE)
110:         DEALLOCATE(NEWPERM, LPERM)106:         DEALLOCATE(NEWPERM, LPERM)
111:     ENDIF107:     ENDIF
112:     ALLOCATE(PDUMMYA(3*NEWNATOMS),PDUMMYB(3*NEWNATOMS),DUMMYA(3*NEWNATOMS), &108:     ALLOCATE(PDUMMYA(3*NEWNATOMS),PDUMMYB(3*NEWNATOMS),DUMMYA(3*NEWNATOMS), &
113:     &   DUMMYB(3*NEWNATOMS), XBESTA(3*NEWNATOMS), XBESTASAVE(3*NEWNATOMS))109:     &   DUMMYB(3*NEWNATOMS), XBESTA(3*NEWNATOMS), XBESTASAVE(3*NEWNATOMS))
114:     ALLOCATE(NEWPERM(NEWNATOMS), LPERM(NEWNATOMS))110:     ALLOCATE(NEWPERM(NEWNATOMS), LPERM(NEWNATOMS))
 111: 
115: ENDIF112: ENDIF
116: 113: 
117: END SUBROUTINE SETNATOMS114: END SUBROUTINE SETNATOMS
118: 115: 
119: SUBROUTINE SETPERM(NEWNATOMS, NEWPERMGROUP, NEWNPERMSIZE)116: SUBROUTINE SETPERM(NEWNATOMS, NEWPERMGROUP, NEWNPERMSIZE)
120: ! Not needed for GMIN/OPTIM/PATHSAMPLE117: ! Not needed for GMIN/OPTIM/PATHSAMPLE
121: ! (Re)allocates arrays that define allowed permuations118: ! (Re)allocates arrays that define allowed permuations
122: IMPLICIT NONE119: IMPLICIT NONE
123: 120: 
124: INTEGER, INTENT(IN) :: NEWNATOMS, NEWPERMGROUP(:), NEWNPERMSIZE(:)121: INTEGER, INTENT(IN) :: NEWNATOMS, NEWPERMGROUP(:), NEWNPERMSIZE(:)
152:     ALLOCATE(NSETS(3*NEWNATOMS))149:     ALLOCATE(NSETS(3*NEWNATOMS))
153: ENDIF150: ENDIF
154: 151: 
155: IF(.NOT.SIZE(SETS).EQ.(3*NEWNATOMS*70)) THEN152: IF(.NOT.SIZE(SETS).EQ.(3*NEWNATOMS*70)) THEN
156:     IF(ALLOCATED(SETS)) THEN153:     IF(ALLOCATED(SETS)) THEN
157:         DEALLOCATE(SETS)154:         DEALLOCATE(SETS)
158:     ENDIF155:     ENDIF
159:     ALLOCATE(SETS(3*NEWNATOMS,70))156:     ALLOCATE(SETS(3*NEWNATOMS,70))
160: ENDIF157: ENDIF
161: 158: 
 159: CALL SETNATOMS(NEWNATOMS)
 160: 
162: NATOMS = NEWNATOMS161: NATOMS = NEWNATOMS
163: PERMGROUP = NEWPERMGROUP162: PERMGROUP = NEWPERMGROUP
164: NPERMSIZE = NEWNPERMSIZE163: NPERMSIZE = NEWNPERMSIZE
165: NSETS = 0164: NSETS = 0
166: 165: 
167: CALL SETNATOMS(NEWNATOMS) 
168:  
169: END SUBROUTINE SETPERM166: END SUBROUTINE SETPERM
170: 167: 
 168: SUBROUTINE FINDBESTPERMUTATION(NATOMS,COORDSB,COORDSA,BOXLX,BOXLY,BOXLZ,BULKT,SAVEPERM,LDISTANCE,DIST2,WORSTRAD)
 169: 
 170: ! Find best permutational alignment of structures COORDSB with COORDSA given
 171: ! LDISTANCE returns the calculated
 172: ! distance^2 between the structures
 173: ! 
 174: ! Code copied under GNU GPL licence from minpermdist.f90 from GMIN 
 175: ! Copyright (C) 1999-2008 David J. Wales
 176: !
 177: IMPLICIT NONE
 178: 
 179: INTEGER, INTENT(IN) :: NATOMS
 180: DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NATOMS), COORDSB(3*NATOMS), BOXLX,BOXLY,BOXLZ
 181: LOGICAL, INTENT(IN) :: BULKT
 182: INTEGER, INTENT(OUT) :: SAVEPERM(NATOMS)
 183: DOUBLE PRECISION, INTENT(OUT) :: LDISTANCE, DIST2, WORSTRAD
 184: 
 185: DOUBLE PRECISION CURRDIST
 186: INTEGER NDUMMY, J, J1, J2, J3, IND1, IND2, PATOMS
 187: 
 188: NDUMMY=1
 189: DO J1=1,NATOMS
 190:     NEWPERM(J1)=J1
 191: ENDDO
 192: 
 193: CURRDIST = 0.D0
 194: DO J1=1,NPERMGROUP
 195:     PATOMS=INT(NPERMSIZE(J1),4)
 196:     DO J2=1,PATOMS
 197:         IND2 = NEWPERM(PERMGROUP(NDUMMY+J2-1))
 198:         PDUMMYA(3*J2-2:3*J2)=COORDSA(3*IND2-2:3*IND2)
 199:         PDUMMYB(3*J2-2:3*J2)=COORDSB(3*IND2-2:3*IND2)
 200:     ENDDO
 201:     CALL MINPERM(PATOMS,PDUMMYB,PDUMMYA,BOXLX,BOXLY,BOXLZ,BULKT,LPERM,LDISTANCE,DIST2,WORSTRAD)
 202:     CURRDIST = CURRDIST + LDISTANCE    
 203:     SAVEPERM(1:NATOMS)=NEWPERM(1:NATOMS)
 204:     DO J2=1,PATOMS
 205:         SAVEPERM(PERMGROUP(NDUMMY+J2-1))=NEWPERM(PERMGROUP(NDUMMY+LPERM(J2)-1))
 206:     ENDDO
 207: 
 208:     IF (NSETS(J1).GT.0) THEN
 209:         DO J2=1,PATOMS
 210:             DO J3=1,NSETS(J1)
 211:                 SAVEPERM(SETS(PERMGROUP(NDUMMY+J2-1),J3))=SETS(NEWPERM(PERMGROUP(NDUMMY+LPERM(J2)-1)),J3)
 212:             ENDDO
 213:         ENDDO
 214:     ENDIF
 215:     NDUMMY=NDUMMY+NPERMSIZE(J1)
 216:     NEWPERM(1:NATOMS)=SAVEPERM(1:NATOMS)
 217: ENDDO
 218: 
 219: LDISTANCE = CURRDIST
 220: DIST2 = SQRT(LDISTANCE)
 221: 
 222: END SUBROUTINE FINDBESTPERMUTATION
 223: 
171: SUBROUTINE SETINDEXES(NEWSHAPE)224: SUBROUTINE SETINDEXES(NEWSHAPE)
172: 225: 
173: ! Helper routine to allocate memory to appropriate arrays needed to perform226: ! Helper routine to allocate memory to appropriate arrays needed to perform
174: ! Levenberg-Marquardt non-linear least-squares curve fitting to find peaks227: ! Levenberg-Marquardt non-linear least-squares curve fitting to find peaks
175: 228: 
176: IMPLICIT NONE229: IMPLICIT NONE
177: 230: 
178: INTEGER, INTENT(IN) :: NEWSHAPE(3)231: INTEGER, INTENT(IN) :: NEWSHAPE(3)
179: 232: 
180: IF (.NOT.ALL(FSHAPE.EQ.NEWSHAPE)) THEN233: IF (.NOT.ALL(FSHAPE.EQ.NEWSHAPE)) THEN
181:     FSHAPE = NEWSHAPE234:     FSHAPE = NEWSHAPE    
182:     IF(ALLOCATED(FSPACE))  DEALLOCATE(FSPACE)235:     IF(ALLOCATED(FSPACE)) THEN
183:     IF(ALLOCATED(FVEC))  DEALLOCATE(FVEC)236:         DEALLOCATE(FSPACE)
184:     IF(ALLOCATED(FJAC)) DEALLOCATE(FJAC)237:     ENDIF
185: 238:     IF(ALLOCATED(FVEC)) THEN
 239:         DEALLOCATE(FVEC)
 240:     ENDIF
 241:     IF(ALLOCATED(FJAC)) THEN
 242:         DEALLOCATE(FJAC)
 243:     ENDIF
 244:     
186:     ALLOCATE( FSPACE( FSHAPE(1),FSHAPE(2),FSHAPE(3) ) )245:     ALLOCATE( FSPACE( FSHAPE(1),FSHAPE(2),FSHAPE(3) ) )
187:     FSIZE = SIZE(FSPACE)246:     FSIZE = SIZE(FSPACE)
188: 247:     
189:     ALLOCATE(FVEC(FSIZE))248:     ALLOCATE(FVEC(FSIZE))
190:     ALLOCATE(FJAC(11,FSIZE))249:     ALLOCATE(FJAC(11,FSIZE))
191: ENDIF250: ENDIF
192: 251: 
193: END SUBROUTINE SETINDEXES252: END SUBROUTINE SETINDEXES
194: 253: 
195: !***********************************************************************254: !***********************************************************************
196: 255: 
197: SUBROUTINE DEALLOCATEFASTUTILS() 
198:  
199: IMPLICIT NONE 
200:  
201: IF(ALLOCATED(FSPACE))  DEALLOCATE(FSPACE) 
202: IF(ALLOCATED(FVEC))  DEALLOCATE(FVEC) 
203: IF(ALLOCATED(FJAC)) DEALLOCATE(FJAC) 
204: IF(ALLOCATED(FSPACECOPY))  DEALLOCATE(FSPACECOPY) 
205: IF(ALLOCATED(GAUSARRAY)) DEALLOCATE(GAUSARRAY) 
206:  
207: IF(ALLOCATED(PDUMMYA)) THEN 
208:     DEALLOCATE(PDUMMYA,PDUMMYB,DUMMYA,DUMMYB,XBESTA,XBESTASAVE) 
209:     DEALLOCATE(NEWPERM, LPERM) 
210: ENDIF 
211:  
212: END SUBROUTINE 
213:  
214: !*********************************************************************** 
215:  
216: SUBROUTINE SETFSPACE(NEWFSPACE)256: SUBROUTINE SETFSPACE(NEWFSPACE)
217: 257: 
218: IMPLICIT NONE258: IMPLICIT NONE
219: 259: 
220: !INTEGER, INTENT(IN) :: NX,NY,NZ260: !INTEGER, INTENT(IN) :: NX,NY,NZ
221: DOUBLE PRECISION, INTENT(IN), DIMENSION(:,:,:) :: NEWFSPACE261: DOUBLE PRECISION, INTENT(IN), DIMENSION(:,:,:) :: NEWFSPACE
222: !INTEGER NSHAPE(3)262: !INTEGER NSHAPE(3)
223: 263: 
224: !NSHAPE=(/NX,NY,NZ/)264: !NSHAPE=(/NX,NY,NZ/)
225: CALL SETINDEXES(SHAPE(NEWFSPACE))265: CALL SETINDEXES(SHAPE(NEWFSPACE))
273:         ENDDO313:         ENDDO
274:     ENDDO314:     ENDDO
275: ENDDO315: ENDDO
276: 316: 
277: END SUBROUTINE GAUSSIAN317: END SUBROUTINE GAUSSIAN
278: 318: 
279: !***********************************************************************319: !***********************************************************************
280: 320: 
281: SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)321: SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG)
282: 322: 
283: !323: ! 
284: ! subroutine passed to lmder1 to perform least squares regression, minimizing324: ! subroutine passed to lmder1 to perform least squares regression, minimizing
285: ! SUM((FOUT - FSPACE)**2)325: ! SUM((FOUT - FSPACE)**2)
286: ! where  FOUT(IX, IY, IZ) = A * Exp(-(I-I0)^T SIGMA (I-I0))326: ! where  FOUT(IX, IY, IZ) = A * Exp(-(I-I0)^T SIGMA (I-I0))
287: ! I = (/IX, IY, IZ/)327: ! I = (/IX, IY, IZ/)
288: !specified by the parameter vector X:328: !specified by the parameter vector X:
289: ! X = (\A, mean, SIGMA(1,1), SIGMA(2,2), SIGMA(3,3), SIGMA(1,2),SIGMA(2,3),SIGMA(1,3), I0(1), I0(2), I0(3) \)329: ! X = (\A, mean, SIGMA(1,1), SIGMA(2,2), SIGMA(3,3), SIGMA(1,2),SIGMA(2,3),SIGMA(1,3), I0(1), I0(2), I0(3) \)
290: ! M = SIZE(FSPACE) is the number of observations330: ! M = SIZE(FSPACE) is the number of observations
291: ! LDFJAC = N specifies the dimension of the jacobian matrix331: ! LDFJAC = N specifies the dimension of the jacobian matrix
292: ! N = 11 is the number of parameters to optimise332: ! N = 11 is the number of parameters to optimise
293: ! If IFLAG=1 then calculates FVEC, the vector of square difference of each observation333: ! If IFLAG=1 then calculates FVEC, the vector of square difference of each observation
351: END SUBROUTINE FCN391: END SUBROUTINE FCN
352: 392: 
353: !***********************************************************************393: !***********************************************************************
354: 394: 
355: SUBROUTINE FIT(X, NEWFSPACE, NX, NY, NZ, INFO, TOL)395: SUBROUTINE FIT(X, NEWFSPACE, NX, NY, NZ, INFO, TOL)
356: 396: 
357: ! This fits a 3 dimensional gaussian of the form397: ! This fits a 3 dimensional gaussian of the form
358: ! A exp (- (I-I0)T Sigma (I-I0) ) + mean398: ! A exp (- (I-I0)T Sigma (I-I0) ) + mean
359: ! Where I is the 3-D vector of the indexes399: ! Where I is the 3-D vector of the indexes
360: ! To the 3 dimensional array specified by FSPACE400: ! To the 3 dimensional array specified by FSPACE
361: ! This uses the Levenberg-Marquardt method.401: ! This uses the Levenberg-Marquardt method. 
362: ! Usage:402: ! Usage:
363: ! CALL FIT(X0, FSPACE, INFO, TOL(optional))403: ! CALL FIT(X0, FSPACE, INFO, TOL(optional))
364: ! X0 = (\A, mean, SIGMA(1,1), SIGMA(2,2), SIGMA(3,3), SIGMA(1,2),SIGMA(2,3),SIGMA(1,3), I0(1), I0(2), I0(3) \)404: ! X0 = (\A, mean, SIGMA(1,1), SIGMA(2,2), SIGMA(3,3), SIGMA(1,2),SIGMA(2,3),SIGMA(1,3), I0(1), I0(2), I0(3) \)
365: !INFO is set as follows:405: !INFO is set as follows:
366: !    0, improper input parameters.406: !    0, improper input parameters.
367: !    1, algorithm estimates that the relative error in the sum of squares407: !    1, algorithm estimates that the relative error in the sum of squares
368: !       is at most TOL.408: !       is at most TOL.
369: !    2, algorithm estimates that the relative error between X and the409: !    2, algorithm estimates that the relative error between X and the
370: !       solution is at most TOL.410: !       solution is at most TOL.
371: !    3, conditions for INFO = 1 and INFO = 2 both hold.411: !    3, conditions for INFO = 1 and INFO = 2 both hold.
490: DOUBLE PRECISION, INTENT(OUT) :: PEAKS(NPEAKS,3), AMPLITUDES(NPEAKS)530: DOUBLE PRECISION, INTENT(OUT) :: PEAKS(NPEAKS,3), AMPLITUDES(NPEAKS)
491: 531: 
492: INTEGER WIDTH, NFOUND, FSHAPE(3), INFO, N, FMAX(3)532: INTEGER WIDTH, NFOUND, FSHAPE(3), INFO, N, FMAX(3)
493: DOUBLE PRECISION T, X(11), PEAK(3)533: DOUBLE PRECISION T, X(11), PEAK(3)
494: DOUBLE PRECISION, ALLOCATABLE :: FSPACECOPY(:,:,:), GAUSARRAY(:,:,:)534: DOUBLE PRECISION, ALLOCATABLE :: FSPACECOPY(:,:,:), GAUSARRAY(:,:,:)
495: 535: 
496: WIDTH = DEFAULTWIDTH536: WIDTH = DEFAULTWIDTH
497: FSHAPE = SHAPE(FSPACE)537: FSHAPE = SHAPE(FSPACE)
498: 538: 
499: IF (.NOT.ALL(SHAPE(FSPACECOPY).EQ.FSHAPE)) THEN539: IF (.NOT.ALL(SHAPE(FSPACECOPY).EQ.FSHAPE)) THEN
500:     IF(ALLOCATED(FSPACECOPY))  DEALLOCATE(FSPACECOPY)540:     IF(ALLOCATED(FSPACECOPY)) THEN
501:     IF(ALLOCATED(GAUSARRAY)) DEALLOCATE(GAUSARRAY)541:         DEALLOCATE(FSPACECOPY)
 542:     ENDIF
 543:     IF(ALLOCATED(GAUSARRAY)) THEN
 544:         DEALLOCATE(GAUSARRAY)
 545:     ENDIF
502:     ALLOCATE(FSPACECOPY(FSHAPE(1),FSHAPE(2),FSHAPE(3)),GAUSARRAY(FSHAPE(1),FSHAPE(2),FSHAPE(3)))546:     ALLOCATE(FSPACECOPY(FSHAPE(1),FSHAPE(2),FSHAPE(3)),GAUSARRAY(FSHAPE(1),FSHAPE(2),FSHAPE(3)))
503: ENDIF547: ENDIF
504: 548: 
505: FSPACECOPY = FSPACE549: FSPACECOPY = FSPACE
506: 550: 
507: NFOUND = 0551: NFOUND = 0
508: DO WHILE(NFOUND.EQ.0)552: DO WHILE(NFOUND.EQ.0)
509:     DO N=1,NPEAKS553:     DO N=1,NPEAKS
510:         CALL FINDPEAK(FSPACECOPY, WIDTH, X, INFO, DEFAULTTOL, FMAX)554:         CALL FINDPEAK(FSPACECOPY, WIDTH, X, INFO, DEFAULTTOL, FMAX)
511: 555: 
545: NPEAKS = NFOUND589: NPEAKS = NFOUND
546: 590: 
547: !DEALLOCATE(FSPACECOPY)591: !DEALLOCATE(FSPACECOPY)
548: !DEALLOCATE(GAUSARRAY)592: !DEALLOCATE(GAUSARRAY)
549: 593: 
550: END SUBROUTINE FINDPEAKS594: END SUBROUTINE FINDPEAKS
551: 595: 
552: !***********************************************************************596: !***********************************************************************
553: ! FFT subroutines597: ! FFT subroutines
554: !***********************************************************************598: !***********************************************************************
555: 599:     
556: SUBROUTINE FFT3D(NX, NY, NZ, IN, OUT)600: SUBROUTINE FFT3D(NX, NY, NZ, IN, OUT)
557: ! calculates forward FFT in 3D601: ! calculates forward FFT in 3D
558: IMPLICIT NONE602: IMPLICIT NONE
559: 603: 
560: INTEGER, INTENT(IN) :: NX, NY, NZ604: INTEGER, INTENT(IN) :: NX, NY, NZ
561: COMPLEX(KIND=REAL64), INTENT(IN) :: IN(NX, NY, NZ)605: COMPLEX(KIND=REAL64), INTENT(IN) :: IN(NX, NY, NZ)
562: COMPLEX(KIND=REAL64), INTENT(OUT) :: OUT(NX, NY, NZ)606: COMPLEX(KIND=REAL64), INTENT(OUT) :: OUT(NX, NY, NZ)
563: 607: 
564: ! INCLUDE "fftw3.f90"608: !INCLUDE "fftw3.f90"
565: INTEGER(KIND=INT64) PLAN_FORWARD609: INTEGER(KIND=INT64) PLAN_FORWARD
566: 610: 
567: CALL DFFTW_PLAN_DFT_3D_(PLAN_FORWARD, NX, NY, NZ, IN, OUT, FFTW_FORWARD, FFTW_ESTIMATE )611: CALL DFFTW_PLAN_DFT_3D_(PLAN_FORWARD, NX, NY, NZ, IN, OUT, FFTW_FORWARD, FFTW_ESTIMATE )
568: CALL DFFTW_EXECUTE_(PLAN_FORWARD)612: CALL DFFTW_EXECUTE_(PLAN_FORWARD)
569: !CALL DFFTW_DESTROY_PLAN(PLAN_FORWARD)613: !CALL DFFTW_DESTROY_PLAN(PLAN_FORWARD)
570: 614: 
571: END SUBROUTINE FFT3D615: END SUBROUTINE FFT3D
572: 616: 
573: !***********************************************************************617: !***********************************************************************
574: 618: 
576: 620: 
577: ! calculates UNNORMALISED inverse fourier transform so,621: ! calculates UNNORMALISED inverse fourier transform so,
578: ! IN == IFFT3D(NX,NY,NZ, FFT3D(NX,NY,NZ, IN))/(NX*NY*NZ)622: ! IN == IFFT3D(NX,NY,NZ, FFT3D(NX,NY,NZ, IN))/(NX*NY*NZ)
579: 623: 
580: IMPLICIT NONE624: IMPLICIT NONE
581: 625: 
582: INTEGER, INTENT(IN) :: NX, NY, NZ626: INTEGER, INTENT(IN) :: NX, NY, NZ
583: COMPLEX(KIND=REAL64), INTENT(IN) :: IN(NX, NY, NZ)627: COMPLEX(KIND=REAL64), INTENT(IN) :: IN(NX, NY, NZ)
584: COMPLEX(KIND=REAL64), INTENT(OUT) :: OUT(NX, NY, NZ)628: COMPLEX(KIND=REAL64), INTENT(OUT) :: OUT(NX, NY, NZ)
585: 629: 
586: ! INCLUDE "fftw3.f90"630: !INCLUDE "fftw3.f90"
587: INTEGER(KIND=INT64) PLAN_BACKWARD631: INTEGER(KIND=INT64) PLAN_BACKWARD
588: 632: 
589: CALL DFFTW_PLAN_DFT_3D_(PLAN_BACKWARD,NX,NY,NZ,IN,OUT,FFTW_BACKWARD,FFTW_ESTIMATE)633: CALL DFFTW_PLAN_DFT_3D_(PLAN_BACKWARD,NX,NY,NZ,IN,OUT,FFTW_BACKWARD,FFTW_ESTIMATE)
590: CALL DFFTW_EXECUTE_(PLAN_BACKWARD)634: CALL DFFTW_EXECUTE_(PLAN_BACKWARD)
591: CALL DFFTW_DESTROY_PLAN_(PLAN_BACKWARD)635: CALL DFFTW_DESTROY_PLAN_(PLAN_BACKWARD)
592: 636: 
593: END SUBROUTINE IFFT3D637: END SUBROUTINE IFFT3D
594: 638: 
595: SUBROUTINE FFT1D(N, IN, OUT)639: SUBROUTINE FFT1D(N, IN, OUT)
596: ! calculates forward FFT in 1D640: ! calculates forward FFT in 1D
597: 641: 
598: IMPLICIT NONE642: IMPLICIT NONE
599: 643: 
600: INTEGER*4, INTENT(IN) :: N644: INTEGER(KIND=INT32), INTENT(IN) :: N
601: COMPLEX(KIND=REAL64), INTENT(IN) :: IN(N)645: COMPLEX(KIND=REAL64), INTENT(IN) :: IN(N)
602: COMPLEX(KIND=REAL64), INTENT(OUT) :: OUT(N)646: COMPLEX(KIND=REAL64), INTENT(OUT) :: OUT(N)
603: 647: 
604: ! INCLUDE "fftw3.f90"648: !INCLUDE "fftw3.f90"
605: INTEGER(KIND=INT64) PLAN_FORWARD649: INTEGER(KIND=INT64) PLAN_FORWARD
606: 650: 
607: CALL DFFTW_PLAN_DFT_1D_(PLAN_FORWARD, N, IN, OUT, FFTW_FORWARD, FFTW_ESTIMATE )651: CALL DFFTW_PLAN_DFT_1D_(PLAN_FORWARD, N, IN, OUT, FFTW_FORWARD, FFTW_ESTIMATE )
608: CALL DFFTW_EXECUTE_(PLAN_FORWARD)652: CALL DFFTW_EXECUTE_(PLAN_FORWARD)
609: CALL DFFTW_DESTROY_PLAN_(PLAN_FORWARD)653: CALL DFFTW_DESTROY_PLAN_(PLAN_FORWARD)
610: 654: 
611: END SUBROUTINE FFT1D655: END SUBROUTINE FFT1D
612: 656: 
613: !***********************************************************************657: !***********************************************************************
614: 658: 
615: SUBROUTINE IFFT1D(N, IN, OUT)659: SUBROUTINE IFFT1D(N, IN, OUT)
616: 660: 
617: ! calculates UNNORMALISED inverse fourier transform so,661: ! calculates UNNORMALISED inverse fourier transform so,
618: ! IN == IFFT1D(N, FFT1D(N, IN))/N662: ! IN == IFFT1D(N, FFT1D(N, IN))/N
619: 663: 
620: IMPLICIT NONE664: IMPLICIT NONE
621: 665: 
622: INTEGER*4, INTENT(IN) :: N666: INTEGER(KIND=INT32), INTENT(IN) :: N
623: COMPLEX(KIND=REAL64), INTENT(IN) :: IN(N)667: COMPLEX(KIND=REAL64), INTENT(IN) :: IN(N)
624: COMPLEX(KIND=REAL64), INTENT(OUT) :: OUT(N)668: COMPLEX(KIND=REAL64), INTENT(OUT) :: OUT(N)
625: 669: 
626: ! INCLUDE "fftw3.f90"670: !INCLUDE "fftw3.f90"
627: INTEGER(KIND=INT64) PLAN_BACKWARD671: INTEGER(KIND=INT64) PLAN_BACKWARD
628: 672: 
629: CALL DFFTW_PLAN_DFT_1D_(PLAN_BACKWARD, N, IN, OUT, FFTW_BACKWARD, FFTW_ESTIMATE )673: CALL DFFTW_PLAN_DFT_1D_(PLAN_BACKWARD, N, IN, OUT, FFTW_BACKWARD, FFTW_ESTIMATE )
630: CALL DFFTW_EXECUTE_(PLAN_BACKWARD)674: CALL DFFTW_EXECUTE_(PLAN_BACKWARD)
631: CALL DFFTW_DESTROY_PLAN_(PLAN_BACKWARD)675: CALL DFFTW_DESTROY_PLAN_(PLAN_BACKWARD)
632: 676: 
633: END SUBROUTINE IFFT1D677: END SUBROUTINE IFFT1D
634: 678: 
635: SUBROUTINE ARGSORT(A,A2,ARGS,N)679: SUBROUTINE ARGSORT(A,A2,ARGS,N)
636: 680: 
706: 750: 
707: DOUBLE PRECISION FUNCTION RLEGENDREL0(L, Z)751: DOUBLE PRECISION FUNCTION RLEGENDREL0(L, Z)
708: 752: 
709: ! Calcualates recurrence factor M1 for associated legendre polynomials@753: ! Calcualates recurrence factor M1 for associated legendre polynomials@
710: ! P^{L+1}_{L+1} (Z) = L0*P^L_L (Z)754: ! P^{L+1}_{L+1} (Z) = L0*P^L_L (Z)
711: 755: 
712: IMPLICIT NONE756: IMPLICIT NONE
713: INTEGER, INTENT(IN) :: L757: INTEGER, INTENT(IN) :: L
714: DOUBLE PRECISION, INTENT(IN) :: Z758: DOUBLE PRECISION, INTENT(IN) :: Z
715: 759: 
716: RLEGENDREL0 = - (2.D0*L+1) * (1-Z**2)**0.5760: RLEGENDREL0 = - (2.D0*L+1) * (1-Z**2)**0.5 
717: 761: 
718: END FUNCTION RLEGENDREL0762: END FUNCTION RLEGENDREL0
719: 763: 
720: 764: 
721: DOUBLE PRECISION FUNCTION RLEGENDREM0(M, L, Z)765: DOUBLE PRECISION FUNCTION RLEGENDREM0(M, L, Z)
722: ! Calcualates recurrence factor M1 for associated legendre polynomials@766: ! Calcualates recurrence factor M1 for associated legendre polynomials@
723: ! P^{M-1}_L (Z) = M0*P^M_L (Z) + M1*P^{M+1}_L (Z)767: ! P^{M-1}_L (Z) = M0*P^M_L (Z) + M1*P^{M+1}_L (Z)
724: 768: 
725: IMPLICIT NONE769: IMPLICIT NONE
726: INTEGER, INTENT(IN) :: M, L770: INTEGER, INTENT(IN) :: M, L
748: !792: !
749: !! ENVJ is a utility function used by MSTA1 and MSTA2.793: !! ENVJ is a utility function used by MSTA1 and MSTA2.
750: !794: !
751: !  Discussion:795: !  Discussion:
752: !796: !
753: !    ENVJ estimates -log(Jn(x)) from the estimate797: !    ENVJ estimates -log(Jn(x)) from the estimate
754: !    Jn(x) approx 1/sqrt(2*pi*n) * ( e*x/(2*n))^n798: !    Jn(x) approx 1/sqrt(2*pi*n) * ( e*x/(2*n))^n
755: !799: !
756: !  Licensing:800: !  Licensing:
757: !801: !
758: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,802: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However, 
759: !    they give permission to incorporate this routine into a user program803: !    they give permission to incorporate this routine into a user program 
760: !    provided that the copyright is acknowledged.804: !    provided that the copyright is acknowledged.
761: !805: !
762: !  Modified:806: !  Modified:
763: !807: !
764: !    14 January 2016808: !    14 January 2016
765: !809: !
766: !  Author:810: !  Author:
767: !811: !
768: !    Shanjie Zhang, Jianming Jin812: !    Shanjie Zhang, Jianming Jin
769: !    Modifications suggested by Vincent Lafage, 11 January 2016.813: !    Modifications suggested by Vincent Lafage, 11 January 2016.
771: !  Reference:815: !  Reference:
772: !816: !
773: !    Shanjie Zhang, Jianming Jin,817: !    Shanjie Zhang, Jianming Jin,
774: !    Computation of Special Functions,818: !    Computation of Special Functions,
775: !    Wiley, 1996,819: !    Wiley, 1996,
776: !    ISBN: 0-471-11963-6,820: !    ISBN: 0-471-11963-6,
777: !    LC: QA351.C45.821: !    LC: QA351.C45.
778: !822: !
779: !  Parameters:823: !  Parameters:
780: !824: !
781: !    Input, integer ( kind = 4 ) N, the order of the Bessel function.825: !    Input, integer ( kind = INT32 ) N, the order of the Bessel function.
782: !826: !
783: !    Input, real ( kind = 8 ) X, the absolute value of the argument.827: !    Input, real ( kind = REAL64 ) X, the absolute value of the argument.
784: !828: !
785: !    Output, real ( kind = 8 ) ENVJ, the value.829: !    Output, real ( kind = REAL64 ) ENVJ, the value.
786: !830: !
 831:   USE PREC, ONLY: INT32, REAL64
 832: 
787:   implicit none833:   implicit none
788: 834: 
789:   real ( kind = 8 ) envj835:   real ( kind = REAL64 ) envj
790:   real ( kind = 8 ) logten836:   real ( kind = REAL64 ) logten
791:   integer ( kind = 4 ) n837:   integer ( kind = INT32 ) n
792:   real ( kind = 8 ) n_r8838:   real ( kind = REAL64 ) n_r8
793:   real ( kind = 8 ) r8_gamma_log839:   real ( kind = REAL64 ) r8_gamma_log
794:   real ( kind = 8 ) x840:   real ( kind = REAL64 ) x
795: !841: !
796: !  Original code842: !  Original code
797: !843: !
798: !  if ( .true. ) then844:   if ( .true. ) then
799: 845: 
800:     envj = 0.5D+00 * log10 ( 6.28D+00 * n ) &846:     envj = 0.5D+00 * log10 ( 6.28D+00 * n ) &
801:       - n * log10 ( 1.36D+00 * x / n )847:       - n * log10 ( 1.36D+00 * x / n )
802: !848: !
803: !  Modification suggested by Vincent Lafage.849: !  Modification suggested by Vincent Lafage.
804: !850: !
805: !  else851:   else
806: 852: 
807: !    n_r8 = real ( n, kind = 8 )853:     n_r8 = real ( n, kind = 8 )
808: !    logten = log ( 10.0D+00 )854:     logten = log ( 10.0D+00 )
809: !    envj = r8_gamma_log ( n_r8 + 1.0D+00 ) / logten - n_r8 * log10 ( x )855:     envj = r8_gamma_log ( n_r8 + 1.0D+00 ) / logten - n_r8 * log10 ( x )
810: 856: 
811: !  end if857:   end if
812: 858: 
813:   return859:   return
814: end860: end
815: 861: 
816: 862: 
817: 863: 
818: function msta1 ( x, mp )864: function msta1 ( x, mp )
819: 865: 
820: !*****************************************************************************80866: !*****************************************************************************80
821: !867: !
822: !! MSTA1 determines a backward recurrence starting point for Jn(x).868: !! MSTA1 determines a backward recurrence starting point for Jn(x).
823: !869: !
824: !  Discussion:870: !  Discussion:
825: !871: !
826: !    This procedure determines the starting point for backward872: !    This procedure determines the starting point for backward  
827: !    recurrence such that the magnitude of873: !    recurrence such that the magnitude of    
828: !    Jn(x) at that point is about 10^(-MP).874: !    Jn(x) at that point is about 10^(-MP).
829: !875: !
830: !  Licensing:876: !  Licensing:
831: !877: !
832: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,878: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However, 
833: !    they give permission to incorporate this routine into a user program879: !    they give permission to incorporate this routine into a user program 
834: !    provided that the copyright is acknowledged.880: !    provided that the copyright is acknowledged.
835: !881: !
836: !  Modified:882: !  Modified:
837: !883: !
838: !    08 July 2012884: !    08 July 2012
839: !885: !
840: !  Author:886: !  Author:
841: !887: !
842: !    Shanjie Zhang, Jianming Jin888: !    Shanjie Zhang, Jianming Jin
843: !889: !
844: !  Reference:890: !  Reference:
845: !891: !
846: !    Shanjie Zhang, Jianming Jin,892: !    Shanjie Zhang, Jianming Jin,
847: !    Computation of Special Functions,893: !    Computation of Special Functions,
848: !    Wiley, 1996,894: !    Wiley, 1996,
849: !    ISBN: 0-471-11963-6,895: !    ISBN: 0-471-11963-6,
850: !    LC: QA351.C45.896: !    LC: QA351.C45.
851: !897: !
852: !  Parameters:898: !  Parameters:
853: !899: !
854: !    Input, real ( kind = 8 ) X, the argument.900: !    Input, real ( kind = REAL64 ) X, the argument.
855: !901: !
856: !    Input, integer ( kind = 4 ) MP, the negative logarithm of the902: !    Input, integer ( kind = INT32 ) MP, the negative logarithm of the 
857: !    desired magnitude.903: !    desired magnitude.
858: !904: !
859: !    Output, integer ( kind = 4 ) MSTA1, the starting point.905: !    Output, integer ( kind = INT32 ) MSTA1, the starting point.
860: !906: !
 907:   USE PREC, ONLY: INT32, REAL64
 908: 
861:   implicit none909:   implicit none
862: 910: 
863:   real ( kind = 8 ) a0911:   real ( kind = REAL64 ) a0
864:   real ( kind = 8 ) envj912:   real ( kind = REAL64 ) envj
865:   real ( kind = 8 ) f913:   real ( kind = REAL64 ) f
866:   real ( kind = 8 ) f0914:   real ( kind = REAL64 ) f0
867:   real ( kind = 8 ) f1915:   real ( kind = REAL64 ) f1
868:   integer ( kind = 4 ) it916:   integer ( kind = INT32 ) it
869:   integer ( kind = 4 ) mp917:   integer ( kind = INT32 ) mp
870:   integer ( kind = 4 ) msta1918:   integer ( kind = INT32 ) msta1
871:   integer ( kind = 4 ) n0919:   integer ( kind = INT32 ) n0
872:   integer ( kind = 4 ) n1920:   integer ( kind = INT32 ) n1
873:   integer ( kind = 4 ) nn921:   integer ( kind = INT32 ) nn
874:   real ( kind = 8 ) x922:   real ( kind = REAL64 ) x
875: 923: 
876:   a0 = abs ( x )924:   a0 = abs ( x )
877:   n0 = int ( 1.1D+00 * a0 ) + 1925:   n0 = int ( 1.1D+00 * a0 ) + 1
878:   f0 = envj ( n0, a0 ) - mp926:   f0 = envj ( n0, a0 ) - mp
879:   n1 = n0 + 5927:   n1 = n0 + 5
880:   f1 = envj ( n1, a0 ) - mp928:   f1 = envj ( n1, a0 ) - mp
881:   do it = 1, 20929:   do it = 1, 20       
882:     nn = n1 - ( n1 - n0 ) / ( 1.0D+00 - f0 / f1 )930:     nn = n1 - ( n1 - n0 ) / ( 1.0D+00 - f0 / f1 )                  
883:     f = envj ( nn, a0 ) - mp931:     f = envj ( nn, a0 ) - mp
884:     if ( abs ( nn - n1 ) < 1 ) then932:     if ( abs ( nn - n1 ) < 1 ) then
885:       exit933:       exit
886:     end if934:     end if
887:     n0 = n1935:     n0 = n1
888:     f0 = f1936:     f0 = f1
889:     n1 = nn937:     n1 = nn
890:     f1 = f938:     f1 = f
891:   end do939:   end do
892: 940: 
903: !951: !
904: !  Discussion:952: !  Discussion:
905: !953: !
906: !    This procedure determines the starting point for a backward954: !    This procedure determines the starting point for a backward
907: !    recurrence such that all Jn(x) has MP significant digits.955: !    recurrence such that all Jn(x) has MP significant digits.
908: !956: !
909: !    Jianming Jin supplied a modification to this code on 12 January 2016.957: !    Jianming Jin supplied a modification to this code on 12 January 2016.
910: !958: !
911: !  Licensing:959: !  Licensing:
912: !960: !
913: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,961: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However, 
914: !    they give permission to incorporate this routine into a user program962: !    they give permission to incorporate this routine into a user program 
915: !    provided that the copyright is acknowledged.963: !    provided that the copyright is acknowledged.
916: !964: !
917: !  Modified:965: !  Modified:
918: !966: !
919: !    14 January 2016967: !    14 January 2016
920: !968: !
921: !  Author:969: !  Author:
922: !970: !
923: !    Shanjie Zhang, Jianming Jin971: !    Shanjie Zhang, Jianming Jin
924: !972: !
925: !  Reference:973: !  Reference:
926: !974: !
927: !    Shanjie Zhang, Jianming Jin,975: !    Shanjie Zhang, Jianming Jin,
928: !    Computation of Special Functions,976: !    Computation of Special Functions,
929: !    Wiley, 1996,977: !    Wiley, 1996,
930: !    ISBN: 0-471-11963-6,978: !    ISBN: 0-471-11963-6,
931: !    LC: QA351.C45.979: !    LC: QA351.C45.
932: !980: !
933: !  Parameters:981: !  Parameters:
934: !982: !
935: !    Input, real ( kind = 8 ) X, the argument of Jn(x).983: !    Input, real ( kind = REAL64 ) X, the argument of Jn(x).
936: !984: !
937: !    Input, integer ( kind = 4 ) N, the order of Jn(x).985: !    Input, integer ( kind = INT32 ) N, the order of Jn(x).
938: !986: !
939: !    Input, integer ( kind = 4 ) MP, the number of significant digits.987: !    Input, integer ( kind = INT32 ) MP, the number of significant digits.
940: !988: !
941: !    Output, integer ( kind = 4 ) MSTA2, the starting point.989: !    Output, integer ( kind = INT32 ) MSTA2, the starting point.
942: !990: !
 991:   USE PREC, ONLY: INT32, REAL64
 992: 
943:   implicit none993:   implicit none
944: 994: 
945:   real ( kind = 8 ) a0995:   real ( kind = REAL64 ) a0
946:   real ( kind = 8 ) ejn996:   real ( kind = REAL64 ) ejn
947:   real ( kind = 8 ) envj997:   real ( kind = REAL64 ) envj
948:   real ( kind = 8 ) f998:   real ( kind = REAL64 ) f
949:   real ( kind = 8 ) f0999:   real ( kind = REAL64 ) f0
950:   real ( kind = 8 ) f11000:   real ( kind = REAL64 ) f1
951:   real ( kind = 8 ) hmp1001:   real ( kind = REAL64 ) hmp
952:   integer ( kind = 4 ) it1002:   integer ( kind = INT32 ) it
953:   integer ( kind = 4 ) mp1003:   integer ( kind = INT32 ) mp
954:   integer ( kind = 4 ) msta21004:   integer ( kind = INT32 ) msta2
955:   integer ( kind = 4 ) n1005:   integer ( kind = INT32 ) n
956:   integer ( kind = 4 ) n01006:   integer ( kind = INT32 ) n0
957:   integer ( kind = 4 ) n11007:   integer ( kind = INT32 ) n1
958:   integer ( kind = 4 ) nn1008:   integer ( kind = INT32 ) nn
959:   real ( kind = 8 ) obj1009:   real ( kind = REAL64 ) obj
960:   real ( kind = 8 ) x1010:   real ( kind = REAL64 ) x
961: 1011: 
962:   a0 = abs ( x )1012:   a0 = abs ( x )
963:   hmp = 0.5D+00 * mp1013:   hmp = 0.5D+00 * mp
964:   ejn = envj ( n, a0 )1014:   ejn = envj ( n, a0 )
965: 1015: 
966:   if ( ejn <= hmp ) then1016:   if ( ejn <= hmp ) then
967:     obj = mp1017:     obj = mp
968: !1018: !
969: !  Original code:1019: !  Original code:
970: !1020: !
1000: end function msta21050: end function msta2
1001: 1051: 
1002: subroutine sphi ( n, x, nm, si)1052: subroutine sphi ( n, x, nm, si)
1003: 1053: 
1004: !*****************************************************************************801054: !*****************************************************************************80
1005: !1055: !
1006: !! SPHI computes spherical Bessel functions in(x) and their derivatives in'(x).1056: !! SPHI computes spherical Bessel functions in(x) and their derivatives in'(x).
1007: !1057: !
1008: !  Licensing:1058: !  Licensing:
1009: !1059: !
1010: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,1060: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However, 
1011: !    they give permission to incorporate this routine into a user program1061: !    they give permission to incorporate this routine into a user program 
1012: !    provided that the copyright is acknowledged.1062: !    provided that the copyright is acknowledged.
1013: !1063: !
1014: !  Modified:1064: !  Modified:
1015: !1065: !
1016: !    18 July 20121066: !    18 July 2012
1017: !1067: !
1018: !  Author:1068: !  Author:
1019: !1069: !
1020: !    Shanjie Zhang, Jianming Jin1070: !    Shanjie Zhang, Jianming Jin
1021: !1071: !
1022: !  Reference:1072: !  Reference:
1023: !1073: !
1024: !    Shanjie Zhang, Jianming Jin,1074: !    Shanjie Zhang, Jianming Jin,
1025: !    Computation of Special Functions,1075: !    Computation of Special Functions,
1026: !    Wiley, 1996,1076: !    Wiley, 1996,
1027: !    ISBN: 0-471-11963-6,1077: !    ISBN: 0-471-11963-6,
1028: !    LC: QA351.C45.1078: !    LC: QA351.C45.
1029: !1079: !
1030: !  Parameters:1080: !  Parameters:
1031: !1081: !
1032: !    Input, integer ( kind = 4 ) N, the order of In(X).1082: !    Input, integer ( kind = INT32 ) N, the order of In(X).
1033: !1083: !
1034: !    Input, real ( kind = 8 ) X, the argument.1084: !    Input, real ( kind = REAL64 ) X, the argument.
1035: !1085: !
1036: !    Output, integer ( kind = 4 ) NM, the highest order computed.1086: !    Output, integer ( kind = INT32 ) NM, the highest order computed.
1037: !1087: !
1038: !    Output, real ( kind = 8 ) SI(0:N), DI(0:N), the values and derivatives1088: !    Output, real ( kind = REAL64 ) SI(0:N), DI(0:N), the values and derivatives
1039: !    of the function of orders 0 through N.1089: !    of the function of orders 0 through N.
1040: !1090: !
 1091:   USE PREC, ONLY: INT32, REAL64
 1092: 
1041:   implicit none1093:   implicit none
1042: 1094: 
1043:   integer ( kind = 4 ), intent(in) :: n1095:   integer ( kind = INT32 ), intent(in) :: n
1044: 1096: 
1045:   real ( kind = 8 ) cs1097:   real ( kind = REAL64 ) cs
1046:   real ( kind = 8 ) f1098:   real ( kind = REAL64 ) f
1047:   real ( kind = 8 ) f01099:   real ( kind = REAL64 ) f0
1048:   real ( kind = 8 ) f11100:   real ( kind = REAL64 ) f1
1049:   integer ( kind = 4 ) k1101:   integer ( kind = INT32 ) k
1050:   integer ( kind = 4 ) m1102:   integer ( kind = INT32 ) m
1051:   integer ( kind = 4 ) msta11103:   integer ( kind = INT32 ) msta1
1052:   integer ( kind = 4 ) msta21104:   integer ( kind = INT32 ) msta2
1053:   integer ( kind = 4 ), intent(out) :: nm1105:   integer ( kind = INT32 ), intent(out) :: nm
1054:   real ( kind = 8 ), intent(out) :: si(0:n)1106:   real ( kind = REAL64 ), intent(out) :: si(0:n)
1055:   real ( kind = 8 ) si01107:   real ( kind = REAL64 ) si0
1056:   real ( kind = 8 ), intent(in) :: x1108:   real ( kind = REAL64 ), intent(in) :: x
1057: 1109: 
1058:   nm = n1110:   nm = n
1059: 1111: 
1060:   if ( abs ( x ) < 1.0D-100 ) then1112:   if ( abs ( x ) < 1.0D-100 ) then
1061:     do k = 0, n1113:     do k = 0, n
1062:       si(k) = 0.0D+001114:       si(k) = 0.0D+00
1063:     end do1115:     end do
1064:     si(0) = 1.0D+001116:     si(0) = 1.0D+00
1065:     return1117:     return
1066:   end if1118:   end if
1099: 1151: 
1100: 1152: 
1101: subroutine HYP1F1 ( ain, bin, xin, hg )1153: subroutine HYP1F1 ( ain, bin, xin, hg )
1102: 1154: 
1103: !*****************************************************************************801155: !*****************************************************************************80
1104: !1156: !
1105: !! CHGM computes the confluent hypergeometric function M(a,b,x).1157: !! CHGM computes the confluent hypergeometric function M(a,b,x).
1106: !1158: !
1107: !  Licensing:1159: !  Licensing:
1108: !1160: !
1109: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,1161: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However, 
1110: !    they give permission to incorporate this routine into a user program1162: !    they give permission to incorporate this routine into a user program 
1111: !    provided that the copyright is acknowledged.1163: !    provided that the copyright is acknowledged.
1112: !1164: !
1113: !  Modified:1165: !  Modified:
1114: !1166: !
1115: !    27 July 20121167: !    27 July 2012
1116: !1168: !
1117: !  Author:1169: !  Author:
1118: !1170: !
1119: !    Shanjie Zhang, Jianming Jin1171: !    Shanjie Zhang, Jianming Jin
1120: !1172: !
1121: !  Reference:1173: !  Reference:
1122: !1174: !
1123: !    Shanjie Zhang, Jianming Jin,1175: !    Shanjie Zhang, Jianming Jin,
1124: !    Computation of Special Functions,1176: !    Computation of Special Functions,
1125: !    Wiley, 1996,1177: !    Wiley, 1996,
1126: !    ISBN: 0-471-11963-6,1178: !    ISBN: 0-471-11963-6,
1127: !    LC: QA351.C45.1179: !    LC: QA351.C45.
1128: !1180: !
1129: !  Parameters:1181: !  Parameters:
1130: !1182: !
1131: !    Input, real ( kind = 8 ) A, B, parameters.1183: !    Input, real ( kind = REAL64 ) A, B, parameters.
1132: !1184: !
1133: !    Input, real ( kind = 8 ) X, the argument.1185: !    Input, real ( kind = REAL64 ) X, the argument.
1134: !1186: !
1135: !    Output, real ( kind = 8 ) HG, the value of M(a,b,x).1187: !    Output, real ( kind = REAL64 ) HG, the value of M(a,b,x).
1136: !1188: !
 1189:   USE PREC, ONLY: INT32, REAL64
 1190: 
1137:   implicit none1191:   implicit none
1138: 1192: 
1139:   real ( kind = 8 ), intent(in) :: ain1193:   real ( kind = REAL64 ), intent(in) :: ain
1140:   real ( kind = 8 ), intent(in) :: bin1194:   real ( kind = REAL64 ), intent(in) :: bin
1141:   real ( kind = 8 ), intent(in) :: xin1195:   real ( kind = REAL64 ), intent(in) :: xin
1142:   real ( kind = 8 ), intent(out) :: hg1196:   real ( kind = REAL64 ), intent(out) :: hg
1143: 1197: 
1144:   real ( kind = 8 ) a1198:   real ( kind = REAL64 ) a
1145:   real ( kind = 8 ) b1199:   real ( kind = REAL64 ) b
1146:   real ( kind = 8 ) x1200:   real ( kind = REAL64 ) x
1147: 1201: 
1148:   real ( kind = 8 ) a01202:   real ( kind = REAL64 ) a0
1149:   real ( kind = 8 ) a11203:   real ( kind = REAL64 ) a1
1150:   real ( kind = 8 ) aa1204:   real ( kind = REAL64 ) aa
1151: 1205: 
1152:   real ( kind = 8 ) hg11206:   real ( kind = REAL64 ) hg1
1153:   real ( kind = 8 ) hg21207:   real ( kind = REAL64 ) hg2
1154:   integer ( kind = 4 ) i1208:   integer ( kind = INT32 ) i
1155:   integer ( kind = 4 ) j1209:   integer ( kind = INT32 ) j
1156:   integer ( kind = 4 ) k1210:   integer ( kind = INT32 ) k
1157:   integer ( kind = 4 ) la1211:   integer ( kind = INT32 ) la
1158:   integer ( kind = 4 ) m1212:   integer ( kind = INT32 ) m
1159:   integer ( kind = 4 ) n1213:   integer ( kind = INT32 ) n
1160:   integer ( kind = 4 ) nl1214:   integer ( kind = INT32 ) nl
1161:   real ( kind = 8 ) pi1215:   real ( kind = REAL64 ) pi
1162:   real ( kind = 8 ) r1216:   real ( kind = REAL64 ) r
1163:   real ( kind = 8 ) r11217:   real ( kind = REAL64 ) r1
1164:   real ( kind = 8 ) r21218:   real ( kind = REAL64 ) r2
1165:   real ( kind = 8 ) rg1219:   real ( kind = REAL64 ) rg
1166:   real ( kind = 8 ) sum11220:   real ( kind = REAL64 ) sum1
1167:   real ( kind = 8 ) sum21221:   real ( kind = REAL64 ) sum2
1168:   real ( kind = 8 ) ta1222:   real ( kind = REAL64 ) ta
1169:   real ( kind = 8 ) tb1223:   real ( kind = REAL64 ) tb
1170:   real ( kind = 8 ) tba1224:   real ( kind = REAL64 ) tba
1171:   real ( kind = 8 ) x01225:   real ( kind = REAL64 ) x0
1172:   real ( kind = 8 ) xg1226:   real ( kind = REAL64 ) xg
1173:   real ( kind = 8 ) y01227:   real ( kind = REAL64 ) y0
1174:   real ( kind = 8 ) y11228:   real ( kind = REAL64 ) y1
1175: 1229: 
1176:   a=ain1230:   a=ain
1177:   b=bin1231:   b=bin
1178:   x=xin1232:   x=xin
1179:   pi = 3.141592653589793D+001233:   pi = 3.141592653589793D+00
1180:   a0 = a1234:   a0 = a
1181:   a1 = a1235:   a1 = a
1182:   x0 = x1236:   x0 = x
1183:   hg = 0.0D+001237:   hg = 0.0D+00
1184: 1238: 
1295: end1349: end
1296: 1350: 
1297: subroutine gamma ( x, ga )1351: subroutine gamma ( x, ga )
1298: 1352: 
1299: !*****************************************************************************801353: !*****************************************************************************80
1300: !1354: !
1301: !! GAMMA evaluates the Gamma function.1355: !! GAMMA evaluates the Gamma function.
1302: !1356: !
1303: !  Licensing:1357: !  Licensing:
1304: !1358: !
1305: !    The original FORTRAN77 version of this routine is copyrighted by1359: !    The original FORTRAN77 version of this routine is copyrighted by 
1306: !    Shanjie Zhang and Jianming Jin.  However, they give permission to1360: !    Shanjie Zhang and Jianming Jin.  However, they give permission to 
1307: !    incorporate this routine into a user program that the copyright1361: !    incorporate this routine into a user program that the copyright 
1308: !    is acknowledged.1362: !    is acknowledged.
1309: !1363: !
1310: !  Modified:1364: !  Modified:
1311: !1365: !
1312: !    08 September 20071366: !    08 September 2007
1313: !1367: !
1314: !  Author:1368: !  Author:
1315: !1369: !
1316: !    Original FORTRAN77 version by Shanjie Zhang, Jianming Jin.1370: !    Original FORTRAN77 version by Shanjie Zhang, Jianming Jin.
1317: !    FORTRAN90 version by John Burkardt.1371: !    FORTRAN90 version by John Burkardt.
1319: !  Reference:1373: !  Reference:
1320: !1374: !
1321: !    Shanjie Zhang, Jianming Jin,1375: !    Shanjie Zhang, Jianming Jin,
1322: !    Computation of Special Functions,1376: !    Computation of Special Functions,
1323: !    Wiley, 1996,1377: !    Wiley, 1996,
1324: !    ISBN: 0-471-11963-6,1378: !    ISBN: 0-471-11963-6,
1325: !    LC: QA351.C451379: !    LC: QA351.C45
1326: !1380: !
1327: !  Parameters:1381: !  Parameters:
1328: !1382: !
1329: !    Input, real ( kind = 8 ) X, the argument.1383: !    Input, real ( kind = REAL64 ) X, the argument.
1330: !    X must not be 0, or any negative integer.1384: !    X must not be 0, or any negative integer.
1331: !1385: !
1332: !    Output, real ( kind = 8 ) GA, the value of the Gamma function.1386: !    Output, real ( kind = REAL64 ) GA, the value of the Gamma function.
1333: !1387: !
 1388:   USE PREC, ONLY: INT32, REAL64
 1389: 
1334:   implicit none1390:   implicit none
1335: 1391: 
1336:   real ( kind = 8 ), intent(in) :: x1392:   real ( kind = REAL64 ), intent(in) :: x
1337:   real ( kind = 8 ), intent(out) :: ga1393:   real ( kind = REAL64 ), intent(out) :: ga
1338: 1394: 
1339:   real ( kind = 8 ), dimension ( 26 ) :: g = (/ &1395:   real ( kind = REAL64 ), dimension ( 26 ) :: g = (/ &
1340:     1.0D+00, &1396:     1.0D+00, &
1341:     0.5772156649015329D+00, &1397:     0.5772156649015329D+00, &
1342:    -0.6558780715202538D+00, &1398:    -0.6558780715202538D+00, &
1343:    -0.420026350340952D-01, &1399:    -0.420026350340952D-01, &
1344:     0.1665386113822915D+00, &1400:     0.1665386113822915D+00, &
1345:    -0.421977345555443D-01, &1401:    -0.421977345555443D-01, &
1346:    -0.96219715278770D-02, &1402:    -0.96219715278770D-02, &
1347:     0.72189432466630D-02, &1403:     0.72189432466630D-02, &
1348:    -0.11651675918591D-02, &1404:    -0.11651675918591D-02, &
1349:    -0.2152416741149D-03, &1405:    -0.2152416741149D-03, &
1350:     0.1280502823882D-03, &1406:     0.1280502823882D-03, & 
1351:    -0.201348547807D-04, &1407:    -0.201348547807D-04, &
1352:    -0.12504934821D-05, &1408:    -0.12504934821D-05, &
1353:     0.11330272320D-05, &1409:     0.11330272320D-05, &
1354:    -0.2056338417D-06, &1410:    -0.2056338417D-06, & 
1355:     0.61160950D-08, &1411:     0.61160950D-08, &
1356:     0.50020075D-08, &1412:     0.50020075D-08, &
1357:    -0.11812746D-08, &1413:    -0.11812746D-08, &
1358:     0.1043427D-09, &1414:     0.1043427D-09, & 
1359:     0.77823D-11, &1415:     0.77823D-11, &
1360:    -0.36968D-11, &1416:    -0.36968D-11, &
1361:     0.51D-12, &1417:     0.51D-12, &
1362:    -0.206D-13, &1418:    -0.206D-13, &
1363:    -0.54D-14, &1419:    -0.54D-14, &
1364:     0.14D-14, &1420:     0.14D-14, &
1365:     0.1D-15 /)1421:     0.1D-15 /)
1366: 1422: 
1367:   real ( kind = 8 ) gr1423:   real ( kind = REAL64 ) gr
1368:   integer ( kind = 4 ) k1424:   integer ( kind = INT32 ) k
1369:   integer ( kind = 4 ) m1425:   integer ( kind = INT32 ) m
1370:   integer ( kind = 4 ) m11426:   integer ( kind = INT32 ) m1
1371:   real ( kind = 8 ), parameter :: pi = 3.141592653589793D+001427:   real ( kind = REAL64 ), parameter :: pi = 3.141592653589793D+00
1372:   real ( kind = 8 ) r1428:   real ( kind = REAL64 ) r
1373:   real ( kind = 8 ) z1429:   real ( kind = REAL64 ) z
1374: 1430: 
1375:   if ( x == aint ( x ) ) then1431:   if ( x == aint ( x ) ) then
1376: 1432: 
1377:     if ( 0.0D+00 < x ) then1433:     if ( 0.0D+00 < x ) then
1378:       ga = 1.0D+001434:       ga = 1.0D+00
1379:       m1 = int ( x ) - 11435:       m1 = int ( x ) - 1
1380:       do k = 2, m11436:       do k = 2, m1
1381:         ga = ga * k1437:         ga = ga * k
1382:       end do1438:       end do
1383:     else1439:     else
1420: 1476: 
1421: 1477: 
1422: !    CODE REPRODUCED FROM MINPACK UNDER THE GNU LPGL LICENCE:1478: !    CODE REPRODUCED FROM MINPACK UNDER THE GNU LPGL LICENCE:
1423: 1479: 
1424: !    REFERENCES:1480: !    REFERENCES:
1425: 1481: 
1426: !    Jorge More, Burton Garbow, Kenneth Hillstrom,1482: !    Jorge More, Burton Garbow, Kenneth Hillstrom,
1427: !    User Guide for MINPACK-1,1483: !    User Guide for MINPACK-1,
1428: !    Technical Report ANL-80-74,1484: !    Technical Report ANL-80-74,
1429: !    Argonne National Laboratory, 1980.1485: !    Argonne National Laboratory, 1980.
1430: 1486:     
1431: !    Jorge More, Danny Sorenson, Burton Garbow, Kenneth Hillstrom,1487: !    Jorge More, Danny Sorenson, Burton Garbow, Kenneth Hillstrom,
1432: !    The MINPACK Project,1488: !    The MINPACK Project,
1433: !    in Sources and Development of Mathematical Software,1489: !    in Sources and Development of Mathematical Software,
1434: !    edited by Wayne Cowell,1490: !    edited by Wayne Cowell,
1435: !    Prentice-Hall, 1984,1491: !    Prentice-Hall, 1984,
1436: !    ISBN: 0-13-823501-5,1492: !    ISBN: 0-13-823501-5,
1437: !    LC: QA76.95.S68.1493: !    LC: QA76.95.S68.
1438: 1494: 
1439: 1495: 
1440: 1496: 
1470: !    Jorge More, Burton Garbow, Kenneth Hillstrom,1526: !    Jorge More, Burton Garbow, Kenneth Hillstrom,
1471: !    User Guide for MINPACK-1,1527: !    User Guide for MINPACK-1,
1472: !    Technical Report ANL-80-74,1528: !    Technical Report ANL-80-74,
1473: !    Argonne National Laboratory, 1980.1529: !    Argonne National Laboratory, 1980.
1474: !1530: !
1475: !  Parameters:1531: !  Parameters:
1476: !1532: !
1477: !    Input, external FCN, the name of the user-supplied subroutine which1533: !    Input, external FCN, the name of the user-supplied subroutine which
1478: !    calculates the functions and the jacobian.  FCN should have the form:1534: !    calculates the functions and the jacobian.  FCN should have the form:
1479: !      subroutine fcn ( m, n, x, fvec, fjac, ldfjac, iflag )1535: !      subroutine fcn ( m, n, x, fvec, fjac, ldfjac, iflag )
1480: !      integer ( kind = 4 ) ldfjac1536: !      integer ( kind = INT32 ) ldfjac
1481: !      integer ( kind = 4 ) n1537: !      integer ( kind = INT32 ) n
1482: !      real ( kind = 8 ) fjac(ldfjac,n)1538: !      real ( kind = REAL64 ) fjac(ldfjac,n)
1483: !      real ( kind = 8 ) fvec(m)1539: !      real ( kind = REAL64 ) fvec(m)
1484: !      integer ( kind = 4 ) iflag1540: !      integer ( kind = INT32 ) iflag
1485: !      real ( kind = 8 ) x(n)1541: !      real ( kind = REAL64 ) x(n)
1486: !1542: !
1487: !    If IFLAG = 0 on input, then FCN is only being called to allow the user1543: !    If IFLAG = 0 on input, then FCN is only being called to allow the user
1488: !    to print out the current iterate.1544: !    to print out the current iterate.
1489: !    If IFLAG = 1 on input, FCN should calculate the functions at X and1545: !    If IFLAG = 1 on input, FCN should calculate the functions at X and
1490: !    return this vector in FVEC.1546: !    return this vector in FVEC.
1491: !    If IFLAG = 2 on input, FCN should calculate the jacobian at X and1547: !    If IFLAG = 2 on input, FCN should calculate the jacobian at X and
1492: !    return this matrix in FJAC.1548: !    return this matrix in FJAC.
1493: !    To terminate the algorithm, FCN may set IFLAG negative on return.1549: !    To terminate the algorithm, FCN may set IFLAG negative on return.
1494: !1550: !
1495: !    Input, integer ( kind = 4 ) M, is the number of functions.1551: !    Input, integer ( kind = INT32 ) M, is the number of functions.
1496: !1552: !
1497: !    Input, integer ( kind = 4 ) N, is the number of variables.1553: !    Input, integer ( kind = INT32 ) N, is the number of variables.  
1498: !    N must not exceed M.1554: !    N must not exceed M.
1499: !1555: !
1500: !    Input/output, real ( kind = 8 ) X(N).  On input, X must contain an initial1556: !    Input/output, real ( kind = REAL64 ) X(N).  On input, X must contain an initial
1501: !    estimate of the solution vector.  On output X contains the final1557: !    estimate of the solution vector.  On output X contains the final
1502: !    estimate of the solution vector.1558: !    estimate of the solution vector.
1503: !1559: !
1504: !    Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X.1560: !    Output, real ( kind = REAL64 ) FVEC(M), the functions evaluated at the output X.
1505: !1561: !
1506: !    Output, real ( kind = 8 ) FJAC(LDFJAC,N), an M by N array.  The upper1562: !    Output, real ( kind = REAL64 ) FJAC(LDFJAC,N), an M by N array.  The upper
1507: !    N by N submatrix of FJAC contains an upper triangular matrix R with1563: !    N by N submatrix of FJAC contains an upper triangular matrix R with
1508: !    diagonal elements of nonincreasing magnitude such that1564: !    diagonal elements of nonincreasing magnitude such that
1509: !      P' * ( JAC' * JAC ) * P = R' * R,1565: !      P' * ( JAC' * JAC ) * P = R' * R,
1510: !    where P is a permutation matrix and JAC is the final calculated jacobian.1566: !    where P is a permutation matrix and JAC is the final calculated jacobian.
1511: !    Column J of P is column IPVT(J) of the identity matrix.  The lower1567: !    Column J of P is column IPVT(J) of the identity matrix.  The lower
1512: !    trapezoidal part of FJAC contains information generated during1568: !    trapezoidal part of FJAC contains information generated during
1513: !    the computation of R.1569: !    the computation of R.
1514: !1570: !
1515: !    Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC.1571: !    Input, integer ( kind = INT32 ) LDFJAC, the leading dimension of FJAC.
1516: !    LDFJAC must be at least M.1572: !    LDFJAC must be at least M.
1517: !1573: !
1518: !    Input, real ( kind = 8 ) FTOL.  Termination occurs when both the actual1574: !    Input, real ( kind = REAL64 ) FTOL.  Termination occurs when both the actual
1519: !    and predicted relative reductions in the sum of squares are at most FTOL.1575: !    and predicted relative reductions in the sum of squares are at most FTOL.
1520: !    Therefore, FTOL measures the relative error desired in the sum of1576: !    Therefore, FTOL measures the relative error desired in the sum of
1521: !    squares.  FTOL should be nonnegative.1577: !    squares.  FTOL should be nonnegative.
1522: !1578: !
1523: !    Input, real ( kind = 8 ) XTOL.  Termination occurs when the relative error1579: !    Input, real ( kind = REAL64 ) XTOL.  Termination occurs when the relative error
1524: !    between two consecutive iterates is at most XTOL.  XTOL should be1580: !    between two consecutive iterates is at most XTOL.  XTOL should be
1525: !    nonnegative.1581: !    nonnegative.
1526: !1582: !
1527: !    Input, real ( kind = 8 ) GTOL.  Termination occurs when the cosine of the1583: !    Input, real ( kind = REAL64 ) GTOL.  Termination occurs when the cosine of the
1528: !    angle between FVEC and any column of the jacobian is at most GTOL in1584: !    angle between FVEC and any column of the jacobian is at most GTOL in
1529: !    absolute value.  Therefore, GTOL measures the orthogonality desired1585: !    absolute value.  Therefore, GTOL measures the orthogonality desired
1530: !    between the function vector and the columns of the jacobian.  GTOL should1586: !    between the function vector and the columns of the jacobian.  GTOL should
1531: !    be nonnegative.1587: !    be nonnegative.
1532: !1588: !
1533: !    Input, integer ( kind = 4 ) MAXFEV.  Termination occurs when the number of1589: !    Input, integer ( kind = INT32 ) MAXFEV.  Termination occurs when the number of
1534: !    calls to FCN with IFLAG = 1 is at least MAXFEV by the end of an iteration.1590: !    calls to FCN with IFLAG = 1 is at least MAXFEV by the end of an iteration.
1535: !1591: !
1536: !    Input/output, real ( kind = 8 ) DIAG(N).  If MODE = 1, then DIAG is set1592: !    Input/output, real ( kind = REAL64 ) DIAG(N).  If MODE = 1, then DIAG is set
1537: !    internally.  If MODE = 2, then DIAG must contain positive entries that1593: !    internally.  If MODE = 2, then DIAG must contain positive entries that
1538: !    serve as multiplicative scale factors for the variables.1594: !    serve as multiplicative scale factors for the variables.
1539: !1595: !
1540: !    Input, integer ( kind = 4 ) MODE, scaling option.1596: !    Input, integer ( kind = INT32 ) MODE, scaling option.
1541: !    1, variables will be scaled internally.1597: !    1, variables will be scaled internally.
1542: !    2, scaling is specified by the input DIAG vector.1598: !    2, scaling is specified by the input DIAG vector.
1543: !1599: !
1544: !    Input, real ( kind = 8 ) FACTOR, determines the initial step bound.  This1600: !    Input, real ( kind = REAL64 ) FACTOR, determines the initial step bound.  This
1545: !    bound is set to the product of FACTOR and the euclidean norm of DIAG*X if1601: !    bound is set to the product of FACTOR and the euclidean norm of DIAG*X if
1546: !    nonzero, or else to FACTOR itself.  In most cases, FACTOR should lie1602: !    nonzero, or else to FACTOR itself.  In most cases, FACTOR should lie
1547: !    in the interval (0.1, 100) with 100 the recommended value.1603: !    in the interval (0.1, 100) with 100 the recommended value.
1548: !1604: !
1549: !    Input, integer ( kind = 4 ) NPRINT, enables controlled printing of iterates1605: !    Input, integer ( kind = INT32 ) NPRINT, enables controlled printing of iterates
1550: !    if it is positive.  In this case, FCN is called with IFLAG = 0 at the1606: !    if it is positive.  In this case, FCN is called with IFLAG = 0 at the
1551: !    beginning of the first iteration and every NPRINT iterations thereafter1607: !    beginning of the first iteration and every NPRINT iterations thereafter
1552: !    and immediately prior to return, with X and FVEC available1608: !    and immediately prior to return, with X and FVEC available
1553: !    for printing.  If NPRINT is not positive, no special calls1609: !    for printing.  If NPRINT is not positive, no special calls
1554: !    of FCN with IFLAG = 0 are made.1610: !    of FCN with IFLAG = 0 are made.
1555: !1611: !
1556: !    Output, integer ( kind = 4 ) INFO, error flag.  If the user has terminated1612: !    Output, integer ( kind = INT32 ) INFO, error flag.  If the user has terminated
1557: !    execution, INFO is set to the (negative) value of IFLAG. See description1613: !    execution, INFO is set to the (negative) value of IFLAG. See description
1558: !    of FCN.  Otherwise, INFO is set as follows:1614: !    of FCN.  Otherwise, INFO is set as follows:
1559: !    0, improper input parameters.1615: !    0, improper input parameters.
1560: !    1, both actual and predicted relative reductions in the sum of1616: !    1, both actual and predicted relative reductions in the sum of
1561: !       squares are at most FTOL.1617: !       squares are at most FTOL.
1562: !    2, relative error between two consecutive iterates is at most XTOL.1618: !    2, relative error between two consecutive iterates is at most XTOL.
1563: !    3, conditions for INFO = 1 and INFO = 2 both hold.1619: !    3, conditions for INFO = 1 and INFO = 2 both hold.
1564: !    4, the cosine of the angle between FVEC and any column of the jacobian1620: !    4, the cosine of the angle between FVEC and any column of the jacobian
1565: !       is at most GTOL in absolute value.1621: !       is at most GTOL in absolute value.
1566: !    5, number of calls to FCN with IFLAG = 1 has reached MAXFEV.1622: !    5, number of calls to FCN with IFLAG = 1 has reached MAXFEV.
1567: !    6, FTOL is too small.  No further reduction in the sum of squares1623: !    6, FTOL is too small.  No further reduction in the sum of squares
1568: !       is possible.1624: !       is possible.
1569: !    7, XTOL is too small.  No further improvement in the approximate1625: !    7, XTOL is too small.  No further improvement in the approximate
1570: !       solution X is possible.1626: !       solution X is possible.
1571: !    8, GTOL is too small.  FVEC is orthogonal to the columns of the1627: !    8, GTOL is too small.  FVEC is orthogonal to the columns of the
1572: !       jacobian to machine precision.1628: !       jacobian to machine precision.
1573: !1629: !
1574: !    Output, integer ( kind = 4 ) NFEV, the number of calls to FCN with1630: !    Output, integer ( kind = INT32 ) NFEV, the number of calls to FCN with
1575: !    IFLAG = 1.1631: !    IFLAG = 1.
1576: !1632: !
1577: !    Output, integer ( kind = 4 ) NJEV, the number of calls to FCN with1633: !    Output, integer ( kind = INT32 ) NJEV, the number of calls to FCN with
1578: !    IFLAG = 2.1634: !    IFLAG = 2.
1579: !1635: !
1580: !    Output, integer ( kind = 4 ) IPVT(N), defines a permutation matrix P1636: !    Output, integer ( kind = INT32 ) IPVT(N), defines a permutation matrix P
1581: !    such that JAC*P = Q*R, where JAC is the final calculated jacobian, Q is1637: !    such that JAC*P = Q*R, where JAC is the final calculated jacobian, Q is
1582: !    orthogonal (not stored), and R is upper triangular with diagonal1638: !    orthogonal (not stored), and R is upper triangular with diagonal
1583: !    elements of nonincreasing magnitude.  Column J of P is column1639: !    elements of nonincreasing magnitude.  Column J of P is column
1584: !    IPVT(J) of the identity matrix.1640: !    IPVT(J) of the identity matrix.
1585: !1641: !
1586: !    Output, real ( kind = 8 ) QTF(N), contains the first N elements of Q'*FVEC.1642: !    Output, real ( kind = REAL64 ) QTF(N), contains the first N elements of Q'*FVEC.
1587: !1643: !
 1644:   USE PREC, ONLY: INT32, REAL64
 1645: 
1588:   implicit none1646:   implicit none
1589: 1647: 
1590:   integer ( kind = 4 ), INTENT(IN) :: ldfjac1648:   integer ( kind = INT32 ), INTENT(IN) :: ldfjac
1591:   integer ( kind = 4 ), INTENT(IN) ::  m1649:   integer ( kind = INT32 ), INTENT(IN) ::  m
1592:   integer ( kind = 4 ), INTENT(IN) ::  n1650:   integer ( kind = INT32 ), INTENT(IN) ::  n
1593: 1651: 
1594:   real ( kind = 8 ) actred1652:   real ( kind = REAL64 ) actred
1595:   real ( kind = 8 ) delta1653:   real ( kind = REAL64 ) delta
1596:   real ( kind = 8 ), INTENT(INOUT) :: diag(n)1654:   real ( kind = REAL64 ), INTENT(INOUT) :: diag(n)
1597:   real ( kind = 8 ) dirder1655:   real ( kind = REAL64 ) dirder
1598:   real ( kind = 8 ) enorm1656:   real ( kind = REAL64 ) enorm
1599:   real ( kind = 8 ) epsmch1657:   real ( kind = REAL64 ) epsmch
1600:   real ( kind = 8 ), INTENT(IN) :: factor1658:   real ( kind = REAL64 ), INTENT(IN) :: factor
1601:   external  fcn1659:   external  fcn
1602:   real ( kind = 8 ), INTENT(OUT) :: fjac(ldfjac,n)1660:   real ( kind = REAL64 ), INTENT(OUT) :: fjac(ldfjac,n)
1603:   real ( kind = 8 ) fnorm1661:   real ( kind = REAL64 ) fnorm
1604:   real ( kind = 8 ) fnorm11662:   real ( kind = REAL64 ) fnorm1
1605:   real ( kind = 8 ), INTENT(IN) :: ftol1663:   real ( kind = REAL64 ), INTENT(IN) :: ftol
1606:   real ( kind = 8 ), INTENT(OUT) :: fvec(m)1664:   real ( kind = REAL64 ), INTENT(OUT) :: fvec(m)
1607:   real ( kind = 8 ) gnorm1665:   real ( kind = REAL64 ) gnorm
1608:   real ( kind = 8 ), INTENT(IN) :: gtol1666:   real ( kind = REAL64 ), INTENT(IN) :: gtol
1609:   integer ( kind = 4 ) i1667:   integer ( kind = INT32 ) i
1610:   integer ( kind = 4 ) iflag1668:   integer ( kind = INT32 ) iflag
1611:   integer ( kind = 4 ), INTENT(OUT) :: info1669:   integer ( kind = INT32 ), INTENT(OUT) :: info
1612:   integer ( kind = 4 ) ipvt(n)1670:   integer ( kind = INT32 ) ipvt(n)
1613:   integer ( kind = 4 ) iter1671:   integer ( kind = INT32 ) iter
1614:   integer ( kind = 4 ) j1672:   integer ( kind = INT32 ) j
1615:   integer ( kind = 4 ) l1673:   integer ( kind = INT32 ) l
1616:   integer ( kind = 4 ), INTENT(IN) :: maxfev1674:   integer ( kind = INT32 ), INTENT(IN) :: maxfev
1617:   integer ( kind = 4 ), INTENT(IN) :: mode1675:   integer ( kind = INT32 ), INTENT(IN) :: mode
1618:   integer ( kind = 4 ), INTENT(OUT) :: nfev1676:   integer ( kind = INT32 ), INTENT(OUT) :: nfev
1619:   integer ( kind = 4 ), INTENT(OUT) :: njev1677:   integer ( kind = INT32 ), INTENT(OUT) :: njev
1620:   integer ( kind = 4 ), INTENT(IN) :: nprint1678:   integer ( kind = INT32 ), INTENT(IN) :: nprint
1621:   real ( kind = 8 ) par1679:   real ( kind = REAL64 ) par
1622:   logical pivot1680:   logical pivot
1623:   real ( kind = 8 ) pnorm1681:   real ( kind = REAL64 ) pnorm
1624:   real ( kind = 8 ) prered1682:   real ( kind = REAL64 ) prered
1625:   real ( kind = 8 ), INTENT(OUT) :: qtf(n)1683:   real ( kind = REAL64 ), INTENT(OUT) :: qtf(n)
1626:   real ( kind = 8 ) ratio1684:   real ( kind = REAL64 ) ratio
1627:   real ( kind = 8 ) sum21685:   real ( kind = REAL64 ) sum2
1628:   real ( kind = 8 ) temp1686:   real ( kind = REAL64 ) temp
1629:   real ( kind = 8 ) temp11687:   real ( kind = REAL64 ) temp1
1630:   real ( kind = 8 ) temp21688:   real ( kind = REAL64 ) temp2
1631:   real ( kind = 8 ) wa1(n)1689:   real ( kind = REAL64 ) wa1(n)
1632:   real ( kind = 8 ) wa2(n)1690:   real ( kind = REAL64 ) wa2(n)
1633:   real ( kind = 8 ) wa3(n)1691:   real ( kind = REAL64 ) wa3(n)
1634:   real ( kind = 8 ) wa4(m)1692:   real ( kind = REAL64 ) wa4(m)
1635:   real ( kind = 8 ) xnorm1693:   real ( kind = REAL64 ) xnorm
1636:   real ( kind = 8 ), INTENT(INOUT) ::  x(n)1694:   real ( kind = REAL64 ), INTENT(INOUT) ::  x(n)
1637:   real ( kind = 8 ), INTENT(IN) :: xtol1695:   real ( kind = REAL64 ), INTENT(IN) :: xtol
1638: 1696: 
1639:   epsmch = epsilon ( epsmch )1697:   epsmch = epsilon ( epsmch )
1640: 1698: 
1641:   info = 01699:   info = 0
1642:   iflag = 01700:   iflag = 0
1643:   nfev = 01701:   nfev = 0
1644:   njev = 01702:   njev = 0
1645: !1703: !
1646: !  Check the input parameters for errors.1704: !  Check the input parameters for errors.
1647: !1705: !
1999: !    Jorge More, Burton Garbow, Kenneth Hillstrom,2057: !    Jorge More, Burton Garbow, Kenneth Hillstrom,
2000: !    User Guide for MINPACK-1,2058: !    User Guide for MINPACK-1,
2001: !    Technical Report ANL-80-74,2059: !    Technical Report ANL-80-74,
2002: !    Argonne National Laboratory, 1980.2060: !    Argonne National Laboratory, 1980.
2003: !2061: !
2004: !  Parameters:2062: !  Parameters:
2005: !2063: !
2006: !    Input, external FCN, the name of the user-supplied subroutine which2064: !    Input, external FCN, the name of the user-supplied subroutine which
2007: !    calculates the functions and the jacobian.  FCN should have the form:2065: !    calculates the functions and the jacobian.  FCN should have the form:
2008: !      subroutine fcn ( m, n, x, fvec, fjac, ldfjac, iflag )2066: !      subroutine fcn ( m, n, x, fvec, fjac, ldfjac, iflag )
2009: !      integer ( kind = 4 ) ldfjac2067: !      integer ( kind = INT32 ) ldfjac
2010: !      integer ( kind = 4 ) n2068: !      integer ( kind = INT32 ) n
2011: !      real ( kind = 8 ) fjac(ldfjac,n)2069: !      real ( kind = REAL64 ) fjac(ldfjac,n)
2012: !      real ( kind = 8 ) fvec(m)2070: !      real ( kind = REAL64 ) fvec(m)
2013: !      integer ( kind = 4 ) iflag2071: !      integer ( kind = INT32 ) iflag
2014: !      real ( kind = 8 ) x(n)2072: !      real ( kind = REAL64 ) x(n)
2015: !2073: !
2016: !    If IFLAG = 0 on input, then FCN is only being called to allow the user2074: !    If IFLAG = 0 on input, then FCN is only being called to allow the user
2017: !    to print out the current iterate.2075: !    to print out the current iterate.
2018: !    If IFLAG = 1 on input, FCN should calculate the functions at X and2076: !    If IFLAG = 1 on input, FCN should calculate the functions at X and
2019: !    return this vector in FVEC.2077: !    return this vector in FVEC.
2020: !    If IFLAG = 2 on input, FCN should calculate the jacobian at X and2078: !    If IFLAG = 2 on input, FCN should calculate the jacobian at X and
2021: !    return this matrix in FJAC.2079: !    return this matrix in FJAC.
2022: !    To terminate the algorithm, FCN may set IFLAG negative on return.2080: !    To terminate the algorithm, FCN may set IFLAG negative on return.
2023: !2081: !
2024: !    Input, integer ( kind = 4 ) M, the number of functions.2082: !    Input, integer ( kind = INT32 ) M, the number of functions.
2025: !2083: !
2026: !    Input, integer ( kind = 4 ) N, is the number of variables.2084: !    Input, integer ( kind = INT32 ) N, is the number of variables.  
2027: !    N must not exceed M.2085: !    N must not exceed M.
2028: !2086: !
2029: !    Input/output, real ( kind = 8 ) X(N).  On input, X must contain an initial2087: !    Input/output, real ( kind = REAL64 ) X(N).  On input, X must contain an initial
2030: !    estimate of the solution vector.  On output X contains the final2088: !    estimate of the solution vector.  On output X contains the final
2031: !    estimate of the solution vector.2089: !    estimate of the solution vector.
2032: !2090: !
2033: !    Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X.2091: !    Output, real ( kind = REAL64 ) FVEC(M), the functions evaluated at the output X.
2034: !2092: !
2035: !    Output, real ( kind = 8 ) FJAC(LDFJAC,N), an M by N array.  The upper2093: !    Output, real ( kind = REAL64 ) FJAC(LDFJAC,N), an M by N array.  The upper
2036: !    N by N submatrix contains an upper triangular matrix R with2094: !    N by N submatrix contains an upper triangular matrix R with
2037: !    diagonal elements of nonincreasing magnitude such that2095: !    diagonal elements of nonincreasing magnitude such that
2038: !      P' * ( JAC' * JAC ) * P = R' * R,2096: !      P' * ( JAC' * JAC ) * P = R' * R,
2039: !    where P is a permutation matrix and JAC is the final calculated2097: !    where P is a permutation matrix and JAC is the final calculated
2040: !    jacobian.  Column J of P is column IPVT(J) of the identity matrix.2098: !    jacobian.  Column J of P is column IPVT(J) of the identity matrix.
2041: !    The lower trapezoidal part of FJAC contains information generated during2099: !    The lower trapezoidal part of FJAC contains information generated during
2042: !    the computation of R.2100: !    the computation of R.
2043: !2101: !
2044: !    Input, integer ( kind = 4 ) LDFJAC, is the leading dimension of FJAC,2102: !    Input, integer ( kind = INT32 ) LDFJAC, is the leading dimension of FJAC,
2045: !    which must be no less than M.2103: !    which must be no less than M.
2046: !2104: !
2047: !    Input, real ( kind = 8 ) TOL.  Termination occurs when the algorithm2105: !    Input, real ( kind = REAL64 ) TOL.  Termination occurs when the algorithm
2048: !    estimates either that the relative error in the sum of squares is at2106: !    estimates either that the relative error in the sum of squares is at
2049: !    most TOL or that the relative error between X and the solution is at2107: !    most TOL or that the relative error between X and the solution is at
2050: !    most TOL.2108: !    most TOL.
2051: !2109: !
2052: !    Output, integer ( kind = 4 ) INFO, error flag.  If the user has terminated2110: !    Output, integer ( kind = INT32 ) INFO, error flag.  If the user has terminated
2053: !    execution, INFO is set to the (negative) value of IFLAG. See description2111: !    execution, INFO is set to the (negative) value of IFLAG. See description
2054: !    of FCN.  Otherwise, INFO is set as follows:2112: !    of FCN.  Otherwise, INFO is set as follows:
2055: !    0, improper input parameters.2113: !    0, improper input parameters.
2056: !    1, algorithm estimates that the relative error in the sum of squares2114: !    1, algorithm estimates that the relative error in the sum of squares
2057: !       is at most TOL.2115: !       is at most TOL.
2058: !    2, algorithm estimates that the relative error between X and the2116: !    2, algorithm estimates that the relative error between X and the
2059: !       solution is at most TOL.2117: !       solution is at most TOL.
2060: !    3, conditions for INFO = 1 and INFO = 2 both hold.2118: !    3, conditions for INFO = 1 and INFO = 2 both hold.
2061: !    4, FVEC is orthogonal to the columns of the jacobian to machine precision.2119: !    4, FVEC is orthogonal to the columns of the jacobian to machine precision.
2062: !    5, number of calls to FCN with IFLAG = 1 has reached 100*(N+1).2120: !    5, number of calls to FCN with IFLAG = 1 has reached 100*(N+1).
2063: !    6, TOL is too small.  No further reduction in the sum of squares is2121: !    6, TOL is too small.  No further reduction in the sum of squares is
2064: !       possible.2122: !       possible.
2065: !    7, TOL is too small.  No further improvement in the approximate2123: !    7, TOL is too small.  No further improvement in the approximate
2066: !       solution X is possible.2124: !       solution X is possible.
2067: !2125: !
 2126:   USE PREC, ONLY: INT32, REAL64
 2127: 
2068:   implicit none2128:   implicit none
2069: 2129: 
2070:   integer ( kind = 4 ), INTENT(IN) ::  ldfjac2130:   integer ( kind = INT32 ), INTENT(IN) ::  ldfjac
2071:   integer ( kind = 4 ), INTENT(IN) ::  m2131:   integer ( kind = INT32 ), INTENT(IN) ::  m
2072:   integer ( kind = 4 ), INTENT(IN) ::  n2132:   integer ( kind = INT32 ), INTENT(IN) ::  n
2073: 2133: 
2074:   real ( kind = 8 ) diag(n)2134:   real ( kind = REAL64 ) diag(n)
2075:   real ( kind = 8 ) factor2135:   real ( kind = REAL64 ) factor
2076:   external fcn2136:   external fcn
2077:   real ( kind = 8 ), INTENT(OUT) ::  fjac(ldfjac,n)2137:   real ( kind = REAL64 ), INTENT(OUT) ::  fjac(ldfjac,n)
2078:   real ( kind = 8 ) ftol2138:   real ( kind = REAL64 ) ftol
2079:   real ( kind = 8 ), INTENT(OUT) ::  fvec(m)2139:   real ( kind = REAL64 ), INTENT(OUT) ::  fvec(m)
2080:   real ( kind = 8 ) gtol2140:   real ( kind = REAL64 ) gtol
2081:   integer ( kind = 4 ), INTENT(OUT) ::  info2141:   integer ( kind = INT32 ), INTENT(OUT) ::  info
2082:   integer ( kind = 4 ) ipvt(n)2142:   integer ( kind = INT32 ) ipvt(n)
2083:   integer ( kind = 4 ) maxfev2143:   integer ( kind = INT32 ) maxfev
2084:   integer ( kind = 4 ) mode2144:   integer ( kind = INT32 ) mode
2085:   integer ( kind = 4 ) nfev2145:   integer ( kind = INT32 ) nfev
2086:   integer ( kind = 4 ) njev2146:   integer ( kind = INT32 ) njev
2087:   integer ( kind = 4 ) nprint2147:   integer ( kind = INT32 ) nprint
2088:   integer ( kind = 4 ) iflag2148:   integer ( kind = INT32 ) iflag
2089:   real ( kind = 8 ) qtf(n)2149:   real ( kind = REAL64 ) qtf(n)
2090:   real ( kind = 8 ), INTENT(IN) ::  tol2150:   real ( kind = REAL64 ), INTENT(IN) ::  tol
2091:   real ( kind = 8 ) x(n)2151:   real ( kind = REAL64 ) x(n)
2092:   real ( kind = 8 ) xtol2152:   real ( kind = REAL64 ) xtol
2093: 2153: 
2094:   info = 02154:   info = 0
2095: 2155: 
2096:   if ( n <= 0 ) then2156:   if ( n <= 0 ) then
2097:     return2157:     return
2098:   else if ( m < n ) then2158:   else if ( m < n ) then
2099:     return2159:     return
2100:   else if ( ldfjac < m ) then2160:   else if ( ldfjac < m ) then
2101:     return2161:     return
2102:   else if ( tol < 0.0D+00 ) then2162:   else if ( tol < 0.0D+00 ) then
2151: !2211: !
2152: !  Reference:2212: !  Reference:
2153: !2213: !
2154: !    Jorge More, Burton Garbow, Kenneth Hillstrom,2214: !    Jorge More, Burton Garbow, Kenneth Hillstrom,
2155: !    User Guide for MINPACK-1,2215: !    User Guide for MINPACK-1,
2156: !    Technical Report ANL-80-74,2216: !    Technical Report ANL-80-74,
2157: !    Argonne National Laboratory, 1980.2217: !    Argonne National Laboratory, 1980.
2158: !2218: !
2159: !  Parameters:2219: !  Parameters:
2160: !2220: !
2161: !    Input, integer ( kind = 4 ) N, is the length of the vector.2221: !    Input, integer ( kind = INT32 ) N, is the length of the vector.
2162: !2222: !
2163: !    Input, real ( kind = 8 ) X(N), the vector whose norm is desired.2223: !    Input, real ( kind = REAL64 ) X(N), the vector whose norm is desired.
2164: !2224: !
2165: !    Output, real ( kind = 8 ) ENORM, the Euclidean norm of the vector.2225: !    Output, real ( kind = REAL64 ) ENORM, the Euclidean norm of the vector.
2166: !2226: !
 2227:   USE PREC, ONLY: INT32, REAL64
 2228: 
2167:   implicit none2229:   implicit none
2168: 2230: 
2169:   integer ( kind = 4 ) n2231:   integer ( kind = INT32 ) n
2170:   real ( kind = 8 ) x(n)2232:   real ( kind = REAL64 ) x(n)
2171:   real ( kind = 8 ) enorm2233:   real ( kind = REAL64 ) enorm
2172: 2234: 
2173:   enorm = sqrt ( sum ( x(1:n) ** 2 ))2235:   enorm = sqrt ( sum ( x(1:n) ** 2 ))
2174: 2236: 
2175:   return2237:   return
2176: end2238: end
2177: 2239: 
2178: function enorm2 ( n, x )2240: function enorm2 ( n, x )
2179: 2241: 
2180: !*****************************************************************************802242: !*****************************************************************************80
2181: !2243: !
2213: !2275: !
2214: !  Reference:2276: !  Reference:
2215: !2277: !
2216: !    Jorge More, Burton Garbow, Kenneth Hillstrom,2278: !    Jorge More, Burton Garbow, Kenneth Hillstrom,
2217: !    User Guide for MINPACK-12279: !    User Guide for MINPACK-1
2218: !    Argonne National Laboratory,2280: !    Argonne National Laboratory,
2219: !    Argonne, Illinois.2281: !    Argonne, Illinois.
2220: !2282: !
2221: !  Parameters:2283: !  Parameters:
2222: !2284: !
2223: !    Input, integer ( kind = 4 ) N, is the length of the vector.2285: !    Input, integer ( kind = INT32 ) N, is the length of the vector.
2224: !2286: !
2225: !    Input, real ( kind = 8 ) X(N), the vector whose norm is desired.2287: !    Input, real ( kind = REAL64 ) X(N), the vector whose norm is desired.
2226: !2288: !
2227: !    Output, real ( kind = 8 ) ENORM2, the Euclidean norm of the vector.2289: !    Output, real ( kind = REAL64 ) ENORM2, the Euclidean norm of the vector.
2228: !2290: !
 2291:   USE PREC, ONLY: INT32, REAL64
 2292: 
2229:   implicit none2293:   implicit none
2230: 2294: 
2231:   integer ( kind = 4 ) n2295:   integer ( kind = INT32 ) n
2232: 2296: 
2233:   real ( kind = 8 ) agiant2297:   real ( kind = REAL64 ) agiant
2234:   real ( kind = 8 ) enorm22298:   real ( kind = REAL64 ) enorm2
2235:   integer ( kind = 4 ) i2299:   integer ( kind = INT32 ) i
2236:   real ( kind = 8 ) rdwarf2300:   real ( kind = REAL64 ) rdwarf
2237:   real ( kind = 8 ) rgiant2301:   real ( kind = REAL64 ) rgiant
2238:   real ( kind = 8 ) s12302:   real ( kind = REAL64 ) s1
2239:   real ( kind = 8 ) s22303:   real ( kind = REAL64 ) s2
2240:   real ( kind = 8 ) s32304:   real ( kind = REAL64 ) s3
2241:   real ( kind = 8 ) x(n)2305:   real ( kind = REAL64 ) x(n)
2242:   real ( kind = 8 ) xabs2306:   real ( kind = REAL64 ) xabs
2243:   real ( kind = 8 ) x1max2307:   real ( kind = REAL64 ) x1max
2244:   real ( kind = 8 ) x3max2308:   real ( kind = REAL64 ) x3max
2245: 2309: 
2246:   rdwarf = sqrt ( tiny ( rdwarf ) )2310:   rdwarf = sqrt ( tiny ( rdwarf ) )
2247:   rgiant = sqrt ( huge ( rgiant ) )2311:   rgiant = sqrt ( huge ( rgiant ) )
2248: 2312: 
2249:   s1 = 0.0D+002313:   s1 = 0.0D+00
2250:   s2 = 0.0D+002314:   s2 = 0.0D+00
2251:   s3 = 0.0D+002315:   s3 = 0.0D+00
2252:   x1max = 0.0D+002316:   x1max = 0.0D+00
2253:   x3max = 0.0D+002317:   x3max = 0.0D+00
2254:   agiant = rgiant / real ( n, kind = 8 )2318:   agiant = rgiant / real ( n, kind = 8 )
2365: !2429: !
2366: !  Reference:2430: !  Reference:
2367: !2431: !
2368: !    Jorge More, Burton Garbow, Kenneth Hillstrom,2432: !    Jorge More, Burton Garbow, Kenneth Hillstrom,
2369: !    User Guide for MINPACK-1,2433: !    User Guide for MINPACK-1,
2370: !    Technical Report ANL-80-74,2434: !    Technical Report ANL-80-74,
2371: !    Argonne National Laboratory, 1980.2435: !    Argonne National Laboratory, 1980.
2372: !2436: !
2373: !  Parameters:2437: !  Parameters:
2374: !2438: !
2375: !    Input, integer ( kind = 4 ) N, the order of R.2439: !    Input, integer ( kind = INT32 ) N, the order of R.
2376: !2440: !
2377: !    Input/output, real ( kind = 8 ) R(LDR,N),the N by N matrix.  The full2441: !    Input/output, real ( kind = REAL64 ) R(LDR,N),the N by N matrix.  The full
2378: !    upper triangle must contain the full upper triangle of the matrix R.2442: !    upper triangle must contain the full upper triangle of the matrix R.
2379: !    On output the full upper triangle is unaltered, and the strict lower2443: !    On output the full upper triangle is unaltered, and the strict lower
2380: !    triangle contains the strict upper triangle (transposed) of the upper2444: !    triangle contains the strict upper triangle (transposed) of the upper
2381: !    triangular matrix S.2445: !    triangular matrix S.
2382: !2446: !
2383: !    Input, integer ( kind = 4 ) LDR, the leading dimension of R.  LDR must be2447: !    Input, integer ( kind = INT32 ) LDR, the leading dimension of R.  LDR must be
2384: !    no less than N.2448: !    no less than N.
2385: !2449: !
2386: !    Input, integer ( kind = 4 ) IPVT(N), defines the permutation matrix P2450: !    Input, integer ( kind = INT32 ) IPVT(N), defines the permutation matrix P 
2387: !    such that A*P = Q*R.  Column J of P is column IPVT(J) of the2451: !    such that A*P = Q*R.  Column J of P is column IPVT(J) of the 
2388: !    identity matrix.2452: !    identity matrix.
2389: !2453: !
2390: !    Input, real ( kind = 8 ) DIAG(N), the diagonal elements of the matrix D.2454: !    Input, real ( kind = REAL64 ) DIAG(N), the diagonal elements of the matrix D.
2391: !2455: !
2392: !    Input, real ( kind = 8 ) QTB(N), the first N elements of the vector Q'*B.2456: !    Input, real ( kind = REAL64 ) QTB(N), the first N elements of the vector Q'*B.
2393: !2457: !
2394: !    Input, real ( kind = 8 ) DELTA, an upper bound on the euclidean norm2458: !    Input, real ( kind = REAL64 ) DELTA, an upper bound on the euclidean norm
2395: !    of D*X.  DELTA should be positive.2459: !    of D*X.  DELTA should be positive.
2396: !2460: !
2397: !    Input/output, real ( kind = 8 ) PAR.  On input an initial estimate of the2461: !    Input/output, real ( kind = REAL64 ) PAR.  On input an initial estimate of the
2398: !    Levenberg-Marquardt parameter.  On output the final estimate.2462: !    Levenberg-Marquardt parameter.  On output the final estimate.
2399: !    PAR should be nonnegative.2463: !    PAR should be nonnegative.
2400: !2464: !
2401: !    Output, real ( kind = 8 ) X(N), the least squares solution of the system2465: !    Output, real ( kind = REAL64 ) X(N), the least squares solution of the system
2402: !    A*X = B, sqrt(PAR)*D*X = 0, for the output value of PAR.2466: !    A*X = B, sqrt(PAR)*D*X = 0, for the output value of PAR.
2403: !2467: !
2404: !    Output, real ( kind = 8 ) SDIAG(N), the diagonal elements of the upper2468: !    Output, real ( kind = REAL64 ) SDIAG(N), the diagonal elements of the upper
2405: !    triangular matrix S.2469: !    triangular matrix S.
2406: !2470: !
 2471:   USE PREC, ONLY: INT32, REAL64
 2472: 
2407:   implicit none2473:   implicit none
2408: 2474: 
2409:   integer ( kind = 4 ) ldr2475:   integer ( kind = INT32 ) ldr
2410:   integer ( kind = 4 ) n2476:   integer ( kind = INT32 ) n
2411: 2477: 
2412:   real ( kind = 8 ) delta2478:   real ( kind = REAL64 ) delta
2413:   real ( kind = 8 ) diag(n)2479:   real ( kind = REAL64 ) diag(n)
2414:   real ( kind = 8 ) dwarf2480:   real ( kind = REAL64 ) dwarf
2415:   real ( kind = 8 ) dxnorm2481:   real ( kind = REAL64 ) dxnorm
2416:   real ( kind = 8 ) enorm2482:   real ( kind = REAL64 ) enorm
2417:   real ( kind = 8 ) gnorm2483:   real ( kind = REAL64 ) gnorm
2418:   real ( kind = 8 ) fp2484:   real ( kind = REAL64 ) fp
2419:   integer ( kind = 4 ) i2485:   integer ( kind = INT32 ) i
2420:   integer ( kind = 4 ) ipvt(n)2486:   integer ( kind = INT32 ) ipvt(n)
2421:   integer ( kind = 4 ) iter2487:   integer ( kind = INT32 ) iter
2422:   integer ( kind = 4 ) j2488:   integer ( kind = INT32 ) j
2423:   integer ( kind = 4 ) k2489:   integer ( kind = INT32 ) k
2424:   integer ( kind = 4 ) l2490:   integer ( kind = INT32 ) l
2425:   integer ( kind = 4 ) nsing2491:   integer ( kind = INT32 ) nsing
2426:   real ( kind = 8 ) par2492:   real ( kind = REAL64 ) par
2427:   real ( kind = 8 ) parc2493:   real ( kind = REAL64 ) parc
2428:   real ( kind = 8 ) parl2494:   real ( kind = REAL64 ) parl
2429:   real ( kind = 8 ) paru2495:   real ( kind = REAL64 ) paru
2430:   real ( kind = 8 ) qnorm2496:   real ( kind = REAL64 ) qnorm
2431:   real ( kind = 8 ) qtb(n)2497:   real ( kind = REAL64 ) qtb(n)
2432:   real ( kind = 8 ) r(ldr,n)2498:   real ( kind = REAL64 ) r(ldr,n)
2433:   real ( kind = 8 ) sdiag(n)2499:   real ( kind = REAL64 ) sdiag(n)
2434:   real ( kind = 8 ) sum22500:   real ( kind = REAL64 ) sum2
2435:   real ( kind = 8 ) temp2501:   real ( kind = REAL64 ) temp
2436:   real ( kind = 8 ) wa1(n)2502:   real ( kind = REAL64 ) wa1(n)
2437:   real ( kind = 8 ) wa2(n)2503:   real ( kind = REAL64 ) wa2(n)
2438:   real ( kind = 8 ) x(n)2504:   real ( kind = REAL64 ) x(n)
2439: !2505: !
2440: !  DWARF is the smallest positive magnitude.2506: !  DWARF is the smallest positive magnitude.
2441: !2507: !
2442:   dwarf = tiny ( dwarf )2508:   dwarf = tiny ( dwarf )
2443: !2509: !
2444: !  Compute and store in X the Gauss-Newton direction.2510: !  Compute and store in X the Gauss-Newton direction.
2445: !2511: !
2446: !  If the jacobian is rank-deficient, obtain a least squares solution.2512: !  If the jacobian is rank-deficient, obtain a least squares solution.
2447: !2513: !
2448:   nsing = n2514:   nsing = n
2530: !2596: !
2531:   par = max ( par, parl )2597:   par = max ( par, parl )
2532:   par = min ( par, paru )2598:   par = min ( par, paru )
2533:   if ( par == 0.0D+00 ) then2599:   if ( par == 0.0D+00 ) then
2534:     par = gnorm / dxnorm2600:     par = gnorm / dxnorm
2535:   end if2601:   end if
2536: !2602: !
2537: !  Beginning of an iteration.2603: !  Beginning of an iteration.
2538: !2604: !
2539:   do2605:   do
2540: 2606:  
2541:     iter = iter + 12607:     iter = iter + 1
2542: !2608: !
2543: !  Evaluate the function at the current value of PAR.2609: !  Evaluate the function at the current value of PAR.
2544: !2610: !
2545:     if ( par == 0.0D+00 ) then2611:     if ( par == 0.0D+00 ) then
2546:       par = max ( dwarf, 0.001D+00 * paru )2612:       par = max ( dwarf, 0.001D+00 * paru )
2547:     end if2613:     end if
2548: 2614: 
2549:     wa1(1:n) = sqrt ( par ) * diag(1:n)2615:     wa1(1:n) = sqrt ( par ) * diag(1:n)
2550: 2616: 
2665: !2731: !
2666: !  Reference:2732: !  Reference:
2667: !2733: !
2668: !    Jorge More, Burton Garbow, Kenneth Hillstrom,2734: !    Jorge More, Burton Garbow, Kenneth Hillstrom,
2669: !    User Guide for MINPACK-1,2735: !    User Guide for MINPACK-1,
2670: !    Technical Report ANL-80-74,2736: !    Technical Report ANL-80-74,
2671: !    Argonne National Laboratory, 1980.2737: !    Argonne National Laboratory, 1980.
2672: !2738: !
2673: !  Parameters:2739: !  Parameters:
2674: !2740: !
2675: !    Input, integer ( kind = 4 ) N, the order of R.2741: !    Input, integer ( kind = INT32 ) N, the order of R.
2676: !2742: !
2677: !    Input/output, real ( kind = 8 ) R(LDR,N), the N by N matrix.2743: !    Input/output, real ( kind = REAL64 ) R(LDR,N), the N by N matrix.
2678: !    On input the full upper triangle must contain the full upper triangle2744: !    On input the full upper triangle must contain the full upper triangle
2679: !    of the matrix R.  On output the full upper triangle is unaltered, and2745: !    of the matrix R.  On output the full upper triangle is unaltered, and
2680: !    the strict lower triangle contains the strict upper triangle2746: !    the strict lower triangle contains the strict upper triangle
2681: !    (transposed) of the upper triangular matrix S.2747: !    (transposed) of the upper triangular matrix S.
2682: !2748: !
2683: !    Input, integer ( kind = 4 ) LDR, the leading dimension of R, which must be2749: !    Input, integer ( kind = INT32 ) LDR, the leading dimension of R, which must be
2684: !    at least N.2750: !    at least N.
2685: !2751: !
2686: !    Input, integer ( kind = 4 ) IPVT(N), defines the permutation matrix P such2752: !    Input, integer ( kind = INT32 ) IPVT(N), defines the permutation matrix P such 
2687: !    that A*P = Q*R.  Column J of P is column IPVT(J) of the identity matrix.2753: !    that A*P = Q*R.  Column J of P is column IPVT(J) of the identity matrix.
2688: !2754: !
2689: !    Input, real ( kind = 8 ) DIAG(N), the diagonal elements of the matrix D.2755: !    Input, real ( kind = REAL64 ) DIAG(N), the diagonal elements of the matrix D.
2690: !2756: !
2691: !    Input, real ( kind = 8 ) QTB(N), the first N elements of the vector Q'*B.2757: !    Input, real ( kind = REAL64 ) QTB(N), the first N elements of the vector Q'*B.
2692: !2758: !
2693: !    Output, real ( kind = 8 ) X(N), the least squares solution.2759: !    Output, real ( kind = REAL64 ) X(N), the least squares solution.
2694: !2760: !
2695: !    Output, real ( kind = 8 ) SDIAG(N), the diagonal elements of the upper2761: !    Output, real ( kind = REAL64 ) SDIAG(N), the diagonal elements of the upper
2696: !    triangular matrix S.2762: !    triangular matrix S.
2697: !2763: !
 2764:   USE PREC, ONLY: INT32, REAL64
 2765: 
2698:   implicit none2766:   implicit none
2699: 2767: 
2700:   integer ( kind = 4 ) ldr2768:   integer ( kind = INT32 ) ldr
2701:   integer ( kind = 4 ) n2769:   integer ( kind = INT32 ) n
2702: 2770: 
2703:   real ( kind = 8 ) c2771:   real ( kind = REAL64 ) c
2704:   real ( kind = 8 ) cotan2772:   real ( kind = REAL64 ) cotan
2705:   real ( kind = 8 ) diag(n)2773:   real ( kind = REAL64 ) diag(n)
2706:   integer ( kind = 4 ) i2774:   integer ( kind = INT32 ) i
2707:   integer ( kind = 4 ) ipvt(n)2775:   integer ( kind = INT32 ) ipvt(n)
2708:   integer ( kind = 4 ) j2776:   integer ( kind = INT32 ) j
2709:   integer ( kind = 4 ) k2777:   integer ( kind = INT32 ) k
2710:   integer ( kind = 4 ) l2778:   integer ( kind = INT32 ) l
2711:   integer ( kind = 4 ) nsing2779:   integer ( kind = INT32 ) nsing
2712:   real ( kind = 8 ) qtb(n)2780:   real ( kind = REAL64 ) qtb(n)
2713:   real ( kind = 8 ) qtbpj2781:   real ( kind = REAL64 ) qtbpj
2714:   real ( kind = 8 ) r(ldr,n)2782:   real ( kind = REAL64 ) r(ldr,n)
2715:   real ( kind = 8 ) s2783:   real ( kind = REAL64 ) s
2716:   real ( kind = 8 ) sdiag(n)2784:   real ( kind = REAL64 ) sdiag(n)
2717:   real ( kind = 8 ) sum22785:   real ( kind = REAL64 ) sum2
2718:   real ( kind = 8 ) t2786:   real ( kind = REAL64 ) t
2719:   real ( kind = 8 ) temp2787:   real ( kind = REAL64 ) temp
2720:   real ( kind = 8 ) wa(n)2788:   real ( kind = REAL64 ) wa(n)
2721:   real ( kind = 8 ) x(n)2789:   real ( kind = REAL64 ) x(n)
2722: !2790: !
2723: !  Copy R and Q'*B to preserve input and initialize S.2791: !  Copy R and Q'*B to preserve input and initialize S.
2724: !2792: !
2725: !  In particular, save the diagonal elements of R in X.2793: !  In particular, save the diagonal elements of R in X.
2726: !2794: !
2727:   do j = 1, n2795:   do j = 1, n
2728:     r(j:n,j) = r(j,j:n)2796:     r(j:n,j) = r(j,j:n)
2729:     x(j) = r(j,j)2797:     x(j) = r(j,j)
2730:   end do2798:   end do
2731: 2799: 
2866: !2934: !
2867: !  Reference:2935: !  Reference:
2868: !2936: !
2869: !    Jorge More, Burton Garbow, Kenneth Hillstrom,2937: !    Jorge More, Burton Garbow, Kenneth Hillstrom,
2870: !    User Guide for MINPACK-1,2938: !    User Guide for MINPACK-1,
2871: !    Technical Report ANL-80-74,2939: !    Technical Report ANL-80-74,
2872: !    Argonne National Laboratory, 1980.2940: !    Argonne National Laboratory, 1980.
2873: !2941: !
2874: !  Parameters:2942: !  Parameters:
2875: !2943: !
2876: !    Input, integer ( kind = 4 ) M, the number of rows of A.2944: !    Input, integer ( kind = INT32 ) M, the number of rows of A.
2877: !2945: !
2878: !    Input, integer ( kind = 4 ) N, the number of columns of A.2946: !    Input, integer ( kind = INT32 ) N, the number of columns of A.
2879: !2947: !
2880: !    Input/output, real ( kind = 8 ) A(LDA,N), the M by N array.2948: !    Input/output, real ( kind = REAL64 ) A(LDA,N), the M by N array.
2881: !    On input, A contains the matrix for which the QR factorization is to2949: !    On input, A contains the matrix for which the QR factorization is to
2882: !    be computed.  On output, the strict upper trapezoidal part of A contains2950: !    be computed.  On output, the strict upper trapezoidal part of A contains
2883: !    the strict upper trapezoidal part of R, and the lower trapezoidal2951: !    the strict upper trapezoidal part of R, and the lower trapezoidal
2884: !    part of A contains a factored form of Q (the non-trivial elements of2952: !    part of A contains a factored form of Q (the non-trivial elements of
2885: !    the U vectors described above).2953: !    the U vectors described above).
2886: !2954: !
2887: !    Input, integer ( kind = 4 ) LDA, the leading dimension of A, which must2955: !    Input, integer ( kind = INT32 ) LDA, the leading dimension of A, which must
2888: !    be no less than M.2956: !    be no less than M.
2889: !2957: !
2890: !    Input, logical PIVOT, is TRUE if column pivoting is to be carried out.2958: !    Input, logical PIVOT, is TRUE if column pivoting is to be carried out.
2891: !2959: !
2892: !    Output, integer ( kind = 4 ) IPVT(LIPVT), defines the permutation matrix P2960: !    Output, integer ( kind = INT32 ) IPVT(LIPVT), defines the permutation matrix P 
2893: !    such that A*P = Q*R.  Column J of P is column IPVT(J) of the identity2961: !    such that A*P = Q*R.  Column J of P is column IPVT(J) of the identity 
2894: !    matrix.  If PIVOT is false, IPVT is not referenced.2962: !    matrix.  If PIVOT is false, IPVT is not referenced.
2895: !2963: !
2896: !    Input, integer ( kind = 4 ) LIPVT, the dimension of IPVT, which should2964: !    Input, integer ( kind = INT32 ) LIPVT, the dimension of IPVT, which should 
2897: !    be N if pivoting is used.2965: !    be N if pivoting is used.
2898: !2966: !
2899: !    Output, real ( kind = 8 ) RDIAG(N), contains the diagonal elements of R.2967: !    Output, real ( kind = REAL64 ) RDIAG(N), contains the diagonal elements of R.
2900: !2968: !
2901: !    Output, real ( kind = 8 ) ACNORM(N), the norms of the corresponding2969: !    Output, real ( kind = REAL64 ) ACNORM(N), the norms of the corresponding
2902: !    columns of the input matrix A.  If this information is not needed,2970: !    columns of the input matrix A.  If this information is not needed,
2903: !    then ACNORM can coincide with RDIAG.2971: !    then ACNORM can coincide with RDIAG.
2904: !2972: !
 2973:   USE PREC, ONLY: INT32, REAL64
 2974: 
2905:   implicit none2975:   implicit none
2906: 2976: 
2907:   integer ( kind = 4 ) lda2977:   integer ( kind = INT32 ) lda
2908:   integer ( kind = 4 ) lipvt2978:   integer ( kind = INT32 ) lipvt
2909:   integer ( kind = 4 ) m2979:   integer ( kind = INT32 ) m
2910:   integer ( kind = 4 ) n2980:   integer ( kind = INT32 ) n
2911: 2981: 
2912:   real ( kind = 8 ) a(lda,n)2982:   real ( kind = REAL64 ) a(lda,n)
2913:   real ( kind = 8 ) acnorm(n)2983:   real ( kind = REAL64 ) acnorm(n)
2914:   real ( kind = 8 ) ajnorm2984:   real ( kind = REAL64 ) ajnorm
2915:   real ( kind = 8 ) enorm2985:   real ( kind = REAL64 ) enorm
2916:   real ( kind = 8 ) epsmch2986:   real ( kind = REAL64 ) epsmch
2917:   integer ( kind = 4 ) i2987:   integer ( kind = INT32 ) i
2918:   integer ( kind = 4 ) i4_temp2988:   integer ( kind = INT32 ) i4_temp
2919:   integer ( kind = 4 ) ipvt(lipvt)2989:   integer ( kind = INT32 ) ipvt(lipvt)
2920:   integer ( kind = 4 ) j2990:   integer ( kind = INT32 ) j
2921:   integer ( kind = 4 ) k2991:   integer ( kind = INT32 ) k
2922:   integer ( kind = 4 ) kmax2992:   integer ( kind = INT32 ) kmax
2923:   integer ( kind = 4 ) minmn2993:   integer ( kind = INT32 ) minmn
2924:   logical pivot2994:   logical pivot
2925:   real ( kind = 8 ) r8_temp(m)2995:   real ( kind = REAL64 ) r8_temp(m)
2926:   real ( kind = 8 ) rdiag(n)2996:   real ( kind = REAL64 ) rdiag(n)
2927:   real ( kind = 8 ) temp2997:   real ( kind = REAL64 ) temp
2928:   real ( kind = 8 ) wa(n)2998:   real ( kind = REAL64 ) wa(n)
2929: 2999: 
2930:   epsmch = epsilon ( epsmch )3000:   epsmch = epsilon ( epsmch )
2931: !3001: !
2932: !  Compute the initial column norms and initialize several arrays.3002: !  Compute the initial column norms and initialize several arrays.
2933: !3003: !
2934:   do j = 1, n3004:   do j = 1, n
2935:     acnorm(j) = enorm ( m, a(1:m,j) )3005:     acnorm(j) = enorm ( m, a(1:m,j) )
2936:   end do3006:   end do
2937: 3007: 
2938:   rdiag(1:n) = acnorm(1:n)3008:   rdiag(1:n) = acnorm(1:n)


r33355/README 2017-09-28 12:30:14.447910085 +0100 r33354/README 2017-09-28 12:30:16.027930885 +0100
  1: This directory contains modules implementing the FASTOVERLAP and GOPERMDIST structural alignment algorithms presented in:  1: This directory contains modules implementing the FASTOVERLAP and GOPERMDIST structural alignment algorithms presented in:
  2: M. Griffiths, S. P. Niblett and D. J. Wales, Optimal Alignment of Structures for Finite and Periodic Systems, JCTC XX, XXXX (2017), DOI: 10.1021/acs.jctc.7b00543  2: M. Griffiths, S. P. Niblett and D. J. Wales, Optimal Alignment of Structures for Finite and Periodic Systems, JCTC XX, XXXX (2017), DOI: 10.1021/acs.jctc.7b00543
  3:   3: 
  4: This fortran implementation was written by M. Griffiths (mg542) and inserted into GMIN by S. Niblett (sn402).  4: This fortran implementation was written by M. Griffiths (mg542) and inserted into GMIN by S. Niblett (sn402).
  5:   5: 
  6: Use of the subroutines  6: Use of the subroutines
  7: ----------------------  7: ----------------------
  8:   8: 
  9: GOPERMDIST   9: *** To be filled in by mg542. In the meantime, take a look at comments in the python version of the code, available from https://github.com/matthewghgriffiths/fastoverlap ***
 10: ---------- 
 11: keyword: BRANCHNBOUND 
 12:  10: 
 13: Globally optimal PERMDIST (GoPERMDIST) is a modification of the PERMDIST algorithm that is guaranteed to find the optimal RMSD, if it is run for long enough. 
 14:  
 15: GoPERMDIST is a branch and bound (BNB) algorithm that attempts to find the best rotation/displacement by searching either a [-pi,pi] sphere of angle axis rotations or searching within the lattice cell. The algorithm starts by placing one initial search cube that fits the entire search region but cubes that reside outide the search region are automatically rejected. 
 16:  
 17: The GoPERMDIST algorithm will stop once the lowest RMSD found is within a certain tolerance of the largest lower bound left. It is possible, though unlikely for there to be a solution between these two values, in which case the GoPERMDIST algorithm may not find the best solution. This situation can be avoided by setting the rtol parameter in the GOPERMDIST module to 0, which will increase the expected runtime of the algorithm. 
 18:  
 19: The time the algorithm needs to find the lowest RMSD will increase as the minimum RMSD between the structures increases. 
 20:  
 21: This method is commonly referred to as BNB. 
 22:  
 23: FASTOVERLAP 
 24: ----------- 
 25: keyword: FASTOVERLAP 
 26:  
 27: This method places Gaussian distributions on top of all the atomic coordinates to produce a 'kernalised' representation of the two structures and then finds the rotation or displacement with the maximum overlap between the two structures.  
 28:  
 29: FASTOVERLAP is very effective for periodic structures. For finite structures the algorithm takes a similar amount of time to the BNB algorithm, so we would generally recommend using the BNB algorithm for clusters. 
 30:  
 31: The FASTOVERLAP algorithm is not guaranteed to work for all pairs of structures, though if the distance between the structures is small then it should work pretty well as the overlap can be used to estimate the RMSD (see the paper for more details). 
 32:  
 33: The FASTOVERLAP algorithm uses FFTs to efficiently calculate the value of the overlap over all rotations or displacements. It then finds the maximum value(s) of the overlap and then uses a variant of the minpermdist algorithm to refine these rotations/displacements. When using FASTOVERLAP the maximum number of maximum values to be tested can be chosen. Testing more peaks can improve the alignment of some of the pairs. The default number of peaks to test is 1.  
 34:  
 35: The performance of the FASTOVERLAP algorithm is fairly dependent on the choice of the kernel width of the Gaussians. In general it has been found that choosing a kernel width of approximately 1/3 of the interatomic spacing is fairly effective. But if there are problems with alignment this is probably the second parameter to fiddle with, after increasing the number of peaks to test 
 36:  
 37: ALIGNUTILS 
 38: ---------- 
 39: This is a reimplementation of the MINPERMDIST subroutine to simplify the logic associated with calling FASTOVERLAP and GOPERMDIST. The ALIGNUTILS module can also save the best NSAVE alignments it finds during the course of its use, set by the logical variable SAVECOORDS in ALIGNUTILS. 
 40:  
 41: 2D 
 42: -- 
 43: BRANCHNBOUND and FASTOVERLAP can work with 2D periodic structures, by setting the allowed displacements in the z-direction to 0.  
 44:  
 45: This means that the input structures must be already aligned in the z-direction. 
 46:  11: 
 47: GMIN interface 12: GMIN interface
 48: -------------- 13: --------------
 49: FASTOVERLAP and GOPERMDIST constitute replacements for the older MINPERMDIST alignment subroutine. FASTOVERLAP is recommended for periodic systems, GOPERMDIST (specified by the keyword BRANCHNBOUND) is recommended for clusters. To preserve backwards-compatibility, MINPERMDIST remains the default alignment method.  14: FASTOVERLAP and GOPERMDIST constitute replacements for the older MINPERMDIST alignment subroutine. FASTOVERLAP is recommended for periodic systems, GOPERMDIST (specified by the keyword BRANCHNBOUND) is recommended for clusters. To preserve backwards-compatibility, MINPERMDIST remains the default alignment method. 
 50: The subroutine ALIGN_DECIDE wraps all three methods, and uses the keywords specified in COMMONS to select one. ALIGN_DECIDE also provides several sanity checks on the keywords and system parameters, to ensure that the method being used is valid. 15: The subroutine ALIGN_DECIDE wraps all three methods, and uses the keywords specified in COMMONS to select one. ALIGN_DECIDE also provides several sanity checks on the keywords and system parameters, to ensure that the method being used is valid.
 51:  16: 
 52: FASTOVERLAP makes use of the FFTW library, which can be found at ${SVN_ROOT}/MYFFTW. This library should be compiled automatically using cmake, more details are given in ${SVN_ROOT}/MYFFTW/CELS_README and as comments in GMIN/source/CMakeLists.txt. 17: FASTOVERLAP makes use of the FFTW library, which can be found at ${SVN_ROOT}/MYFFTW. This library should be compiled automatically using cmake, more details are given in ${SVN_ROOT}/MYFFTW/CELS_README and as comments in GMIN/source/CMakeLists.txt.


legend
Lines Added 
Lines changed
 Lines Removed

hdiff - version: 2.1.0