hdiff output

r33371/ALIGN 2017-10-04 18:30:07.288173256 +0100 r33370/ALIGN 2017-10-04 18:30:10.572216879 +0100
  1: svn: warning: W195007: URL 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/OPTIM/source/ALIGN' refers to a directory  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/OPTIM/source/ALIGN' in revision 33370
  2: svn: E200009: Could not cat all targets because some targets are directories 
  3: svn: E200009: Illegal target for the requested operation 


r33371/align_decide.f90 2017-10-04 18:30:07.700178995 +0100 r33370/align_decide.f90 2017-10-04 18:30:11.012222685 +0100
  1: SUBROUTINE ALIGN_DECIDE(COORDSB,COORDSA,NATOMS,DEBUG,NBOXLX,NBOXLY,NBOXLZ,BULKT,TWOD,DISTANCE,DIST2,RIGID,RMATBEST)  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/OPTIM/source/ALIGN/align_decide.f90' in revision 33370
  2:  
  3: USE KEY, ONLY: FASTOVERLAPT, BNB_ALIGNT, &    ! Logicals to determine which alignment routine to use 
  4:                KERNELWIDTH,NDISPLACEMENTS, &  ! Parameters for the Bulk FASTOVERLAP routine 
  5:                MAX_ANGMOM, NROTATIONS, &      ! Parameters for the Cluster FASTOVERLAP routine 
  6:                BNB_NSTEPS, &                  ! Parameter for the BNB align routine     
  7:                BULK_BOXVEC, &                 ! Misc variables from the main program 
  8:                NSETS, PERMDIST, LOCALPERMDIST, NOINVERSION 
  9:  
 10: USE GENRIGID, ONLY: RIGIDINIT, ATOMRIGIDCOORDT    ! Keywords that need checking for compatibility 
 11: USE BULKFASTOVERLAP, ONLY: FOM_ALIGN_BULK 
 12: USE CLUSTERFASTOVERLAP, ONLY: FOM_ALIGN_CLUSTERS, ALIGNHARM 
 13: USE GOPERMDIST, ONLY: BNB_ALIGN 
 14:  
 15: IMPLICIT NONE 
 16:  
 17: INTEGER NATOMS 
 18: DOUBLE PRECISION DIST2, COORDSA(3*NATOMS), COORDSB(3*NATOMS), DISTANCE, RMATBEST(3,3) 
 19: LOGICAL DEBUG, TWOD, RIGID, BULKT 
 20: DOUBLE PRECISION NBOXLX,NBOXLY,NBOXLZ 
 21:  
 22: ! Start by performing some sanity checks, to make sure the keywords being used are compatible with the requested alignment method. 
 23:  
 24: IF (DEBUG .AND. BULKT .AND. ((ABS(NBOXLX-BULK_BOXVEC(1)).GT.1.0D-8) .OR. (ABS(NBOXLY-BULK_BOXVEC(2)).GT.1.0D-8) .OR. (ABS(NBOXLZ-BULK_BOXVEC(3)).GT.1.0D-8))) THEN 
 25:    WRITE(*,*) "align_decide> ERROR: Box parameters passed in as arguments differ to those USEd from COMMONS." 
 26:    WRITE(*,*) "Passed in: ", NBOXLX,NBOXLY,NBOXLZ 
 27:    WRITE(*,*) "USEd: ", BULK_BOXVEC(:) 
 28:    STOP 1 
 29: ENDIF   
 30:  
 31: IF (FASTOVERLAPT .OR. BNB_ALIGNT) THEN 
 32:    IF ((RIGIDINIT .AND. (.NOT.ATOMRIGIDCOORDT)) .OR. RIGID) THEN 
 33:       WRITE(*,*) "align_decide> fastoverlap and BNB methods do not work in rigid body coordinates. Use cartesians instead." 
 34:       STOP 
 35:    ELSEIF (ALLOCATED(NSETS)) THEN 
 36:       IF (ANY(NSETS(:).GT.0)) THEN 
 37:          WRITE(*,*) "align_decide> fastoverlap and BNB methods are not tested for secondary permutable sets, and probably don't work. Stopping now." 
 38:          STOP 
 39:       ENDIF 
 40:    ENDIF 
 41: ENDIF 
 42:  
 43: ! Now perform the actual alignment call. 
 44:  
 45: ! FASTOVERLAP and BNB are not designed to work with LOCALPERMDIST. 
 46: ! Using these new routines for non-permutable systems (without PERMDIST) is unnecessary and likely to be inefficient. 
 47: ! So in both of these cases, we bypass the new alignment routines and go straight to MINPERMDIST. 
 48: IF (PERMDIST .AND. (.NOT. LOCALPERMDIST)) THEN 
 49:  
 50:    IF (FASTOVERLAPT) THEN  ! Without PERMDIST, we definitely don't need to call the ALIGN routines. 
 51:     
 52:       IF(BULKT) THEN 
 53:  
 54:          IF (.NOT. NOINVERSION) THEN 
 55:             IF (DEBUG) THEN 
 56:                WRITE(*,*) "align_decide> Warning: Bulk FASTOVERLAP does not support checking for inversion symmetry only. Setting NOINVERSION=.TRUE." 
 57:                WRITE(*,*) "align_decide> Use the OHCELL keyword to account for symmetries of a cubic box." 
 58:             ENDIF 
 59:             NOINVERSION = .TRUE. 
 60:          ENDIF 
 61:  
 62:          IF (DEBUG) WRITE(*,*) "align_decide> using fastoverlap periodic alignment" 
 63:          CALL FOM_ALIGN_BULK(COORDSB,COORDSA,NATOMS,DEBUG,NBOXLX,NBOXLY,NBOXLZ,KERNELWIDTH,NDISPLACEMENTS,DISTANCE,DIST2) 
 64:       ELSE 
 65:          IF (DEBUG) WRITE(*,*) "align_decide> using fastoverlap cluster alignment" 
 66:          CALL FOM_ALIGN_CLUSTERS(COORDSB,COORDSA,NATOMS,DEBUG,MAX_ANGMOM,KERNELWIDTH,DISTANCE,DIST2,RMATBEST,NROTATIONS) 
 67:       ENDIF 
 68:  
 69:    ELSE IF (BNB_ALIGNT) THEN 
 70:  
 71:       IF(DEBUG) WRITE(*,*) "align_decide> using BNB align" 
 72:       CALL BNB_ALIGN(COORDSB,COORDSA,NATOMS,DEBUG,NBOXLX,NBOXLY,NBOXLZ,BULKT,DISTANCE,DIST2,RMATBEST,BNB_NSTEPS) 
 73:  
 74:    ELSE 
 75:   
 76:       IF(DEBUG) WRITE(*,*) "align_decide> using original MINPERMDIST routine" 
 77:       CALL MINPERMDIST(COORDSB,COORDSA,NATOMS,DEBUG,NBOXLX,NBOXLY,NBOXLZ,BULKT,TWOD,DISTANCE,DIST2,RIGID,RMATBEST) 
 78:  
 79:    ENDIF 
 80:  
 81: ELSE  
 82:  
 83:   IF (DEBUG .AND. (FASTOVERLAPT .OR. BNB_ALIGNT)) THEN 
 84:       WRITE(*,*) "Warning: Specified new ALIGN routines without PERMDIST or with LOCALPERMDIST. Using MINPERMDIST instead." 
 85:    ENDIF 
 86:    IF(DEBUG) WRITE(*,*) "align_decide> using original MINPERMDIST routine" 
 87:    CALL MINPERMDIST(COORDSB,COORDSA,NATOMS,DEBUG,NBOXLX,NBOXLY,NBOXLZ,BULKT,TWOD,DISTANCE,DIST2,RIGID,RMATBEST) 
 88:  
 89:  ENDIF 
 90:  
 91:  
 92: END SUBROUTINE 


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


r33371/bnbalign.f90 2017-10-04 18:30:08.136184749 +0100 r33370/bnbalign.f90 2017-10-04 18:30:11.452228489 +0100
  1: ! Subroutines:  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/OPTIM/source/ALIGN/bnbalign.f90' in revision 33370
  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:  
 44: !    QUEUELEN() 
 45:  
 46: !*********************************************************************** 
 47:  
 48: MODULE GOPERMDIST 
 49:  
 50: ! USE COMMONS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM, & 
 51: ! & NSETS, SETS, OHCELLT, PERMDIST, PERMOPT, BOXLX, BOXLY, BOXLZ 
 52: USE ALIGNUTILS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM, & 
 53:  & NSETS, SETS, DEBUG, OHCELLT, NOINVERSION, BULK_BOXVEC, & 
 54:  & TWOD, SAVECOORDS, NSTORED 
 55: USE PRIORITYQUEUE, ONLY: QUEUE 
 56: USE PREC, ONLY: INT64, REAL64 
 57:  
 58: IMPLICIT NONE 
 59:  
 60: INTEGER, SAVE :: NATOMS, NCALC, NLAP, NQUENCH, NBAD 
 61: INTEGER, SAVE :: PMAXNEI = 60 ! Number of nearest neighbours to store 
 62: INTEGER, SAVE :: PRINTRATE = 1 
 63: DOUBLE PRECISION, PARAMETER :: PSCALE = 1.D6 ! Scale for linear assignment problem 
 64: DOUBLE PRECISION, PARAMETER :: PI = 3.141592653589793D0 
 65: ! Absolute Tolerance, Relative Tolerance, Relative Tolerance for MINPERMDIST quench 
 66: DOUBLE PRECISION, SAVE :: ATOL=1D-8, RTOL=1D-1, MPRTOL=1.D-1 
 67:  
 68: DOUBLE PRECISION, SAVE :: LVECS(3,0:8), FVECS(4,6), TWODVECS(3,0:4) 
 69:  
 70: DOUBLE PRECISION, SAVE :: CMAX,CMAY,CMAZ,CMBX,CMBY,CMBZ 
 71: DOUBLE PRECISION, SAVE :: DUMMYRMAT(3,3), TRMAT(3,3), DUMMYDISP(3) 
 72: LOGICAL, SAVE :: FORCEASSIGNMENT=.FALSE. 
 73:  
 74: ! Module saves periodic conditions variables 
 75: LOGICAL, SAVE :: BULKT 
 76: LOGICAL, SAVE :: OHCELLTSAVE 
 77: DOUBLE PRECISION, SAVE :: BOXVEC(3), DISPBEST(3) 
 78:  
 79: ! Arrays to store target and candidate structures and best found structures 
 80: DOUBLE PRECISION, SAVE, ALLOCATABLE  :: SAVECOORDSA(:,:),PERMCOORDSB(:,:,:), & 
 81:  & SAVECOORDSB(:), BESTCOORDSA(:,:), BESTRMAT(:,:,:), BESTDISP(:,:) 
 82: DOUBLE PRECISION, SAVE, ALLOCATABLE  :: SAVERA(:,:), SAVERB(:) 
 83: INTEGER, SAVE, ALLOCATABLE :: BESTITERS(:), BESTPERMS(:,:) 
 84: INTEGER, SAVE :: BESTID, BESTITER 
 85:  
 86:  
 87: ! Used when calculating Boundsin CALCBOUNDS 
 88: DOUBLE PRECISION :: BRANCHVECS(3,8) 
 89: DOUBLE PRECISION, SAVE, ALLOCATABLE  :: DUMMYCOORDSA(:,:), PDUMMYND(:) 
 90: ! Arrays of distances and nearest neighbour distances 
 91:  
 92: DOUBLE PRECISION, SAVE, ALLOCATABLE :: DUMMYDISTS(:,:), DUMMYNEARDISTS(:) 
 93:  
 94: DOUBLE PRECISION, SAVE, ALLOCATABLE :: DUMMYDISPS(:,:,:) 
 95: ! Arrays of bounded distances and nearest neighbour distances 
 96: DOUBLE PRECISION, SAVE, ALLOCATABLE :: DUMMYLDISTS(:,:), DUMMYNEARLDISTS(:), & 
 97:  & DUMMYLDISTS2(:,:), DUMMYDOTDISP(:,:,:) 
 98:  
 99: INTEGER, SAVE, ALLOCATABLE :: DUMMYIDX(:,:), DINVIDX(:,:), DUMMYNEARIDX(:) 
100: INTEGER, SAVE, ALLOCATABLE :: INVPERMGROUP(:) 
101:  
102: ! Used when solving assignment problem 
103: DOUBLE PRECISION, SAVE, ALLOCATABLE :: PDUMMYA(:), PDUMMYB(:), DUMMYA(:), & 
104:     & DUMMYB(:), XBESTA(:), XBESTASAVE(:) 
105:  
106: INTEGER, SAVE, ALLOCATABLE :: NEWPERM(:), LPERM(:), PERMBEST(:) 
107:  
108: TYPE(QUEUE) :: Q 
109:  
110: DATA LVECS / & 
111:  &  0.0D0,  0.0D0,  0.0D0, & 
112:  &  1.0D0,  1.0D0,  1.0D0, & 
113:  &  1.0D0,  1.0D0, -1.0D0, & 
114:  &  1.0D0, -1.0D0,  1.0D0, & 
115:  &  1.0D0, -1.0D0, -1.0D0, & 
116:  & -1.0D0,  1.0D0,  1.0D0, & 
117:  & -1.0D0,  1.0D0, -1.0D0, & 
118:  & -1.0D0, -1.0D0,  1.0D0, & 
119:  & -1.0D0, -1.0D0, -1.0D0 / 
120:  
121: DATA FVECS / & 
122:  &  1.0D0,  1.0D0,  1.0D0,  1.0D0, & 
123:  &  1.0D0,  1.0D0, -1.0D0, -1.0D0, & 
124:  &  1.0D0, -1.0D0,  1.0D0, -1.0D0, & 
125:  & -1.0D0, -1.0D0, -1.0D0, -1.0D0, & 
126:  & -1.0D0, -1.0D0,  1.0D0,  1.0D0, & 
127:  & -1.0D0,  1.0D0, -1.0D0,  1.0D0 / 
128:  
129: DATA TWODVECS / & 
130:  &  0.0D0,  0.0D0,  0.0D0, & 
131:  &  1.0D0,  1.0D0,  0.0D0, & 
132:  &  1.0D0, -1.0D0,  0.0D0, & 
133:  & -1.0D0,  1.0D0,  0.0D0, & 
134:  & -1.0D0, -1.0D0,  0.0D0 / 
135:  
136: ! Private so that module works with f2py and static linking to priorityqueue.f90 
137: PRIVATE :: Q 
138:  
139: CONTAINS 
140:  
141: SUBROUTINE BNB_ALIGN(COORDSB,COORDSA,NCOORDS,DEBUGT,NBOXLX,NBOXLY,NBOXLZ,NBULKT, & 
142:     & DISTANCE,DIST2,RMATBEST,NSTEPS) 
143:  
144: IMPLICIT NONE 
145:  
146: LOGICAL, INTENT(IN) :: NBULKT, DEBUGT 
147: INTEGER, INTENT(IN) :: NCOORDS, NSTEPS 
148: DOUBLE PRECISION, INTENT(INOUT) :: COORDSB(3*NCOORDS), COORDSA(3*NCOORDS) 
149: DOUBLE PRECISION, INTENT(IN) :: NBOXLX, NBOXLY, NBOXLZ 
150:  
151: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2, RMATBEST(3,3) 
152:  
153: DOUBLE PRECISION VECTOR(3), WIDTH, BESTUPPER, LOWERBOUND, UPPERBOUND 
154: INTEGER IDNUM 
155:  
156: ! Allocating and assigning to temporary arrays 
157: NATOMS = NCOORDS 
158: !CALL SETNATOMS(NATOMS) 
159: CALL INITIALISE(COORDSB, COORDSA, NATOMS, NBOXLX, NBOXLY, NBOXLZ, NBULKT) 
160:  
161: ! Setting parameters 
162: DEBUG = DEBUGT 
163: NSTORED = 0 ! For saving coordinates 
164: BESTUPPER = HUGE(1.D0) 
165: VECTOR(:) = 0.D0 
166: IF(BULKT) THEN 
167:     WIDTH = MAX(NBOXLX, NBOXLY, NBOXLZ) 
168: ELSE 
169:     WIDTH = 2.D0 * PI 
170: END IF 
171:  
172: ! Initialise BnB nodes 
173: IDNUM = 1 
174: ! Standard search region 
175: CALL ADDNODE(VECTOR,WIDTH,IDNUM,BESTUPPER,.TRUE.,LOWERBOUND,UPPERBOUND) 
176:  
177: IF(BULKT.AND.OHCELLT) THEN 
178:     ! Adding all 48 octahedral symmetries 
179:     DO IDNUM=2,48 
180:         CALL ADDNODE(VECTOR,WIDTH,IDNUM,BESTUPPER,.TRUE.,LOWERBOUND,UPPERBOUND) 
181:     END DO 
182: ELSE IF(.NOT. NOINVERSION) THEN 
183:     ! Adding permutation inversion isomer 
184:     CALL ADDNODE(VECTOR,WIDTH,2,BESTUPPER,.TRUE.,LOWERBOUND,UPPERBOUND) 
185: END IF 
186:  
187: ! Perform BnB 
188: CALL RUN(NSTEPS,FORCEASSIGNMENT,PRINTRATE,BESTUPPER) 
189:  
190: ! Return results 
191: COORDSB(:) = SAVECOORDSB(:) 
192: COORDSA(:) = BESTCOORDSA(:,BESTID) 
193:  
194: DISTANCE = BESTUPPER 
195: DIST2 = DISTANCE**2 
196:  
197: IF (NBULKT) THEN 
198:         DISPBEST = BESTDISP(:,BESTID) 
199: ELSE 
200:     RMATBEST = BESTRMAT(:,:,BESTID) 
201: ENDIF 
202:  
203: BESTPERM = BESTPERMS(:,BESTID) 
204:  
205: END SUBROUTINE BNB_ALIGN 
206:  
207: SUBROUTINE RUN(NITER, FORCE, IPRINT, BESTUPPER) 
208:  
209: USE ALIGNUTILS, ONLY : PRINTDISTANCES 
210: IMPLICIT NONE 
211:  
212: INTEGER, INTENT(IN) :: NITER, IPRINT 
213: LOGICAL, INTENT(IN) :: FORCE 
214: DOUBLE PRECISION, INTENT(INOUT) :: BESTUPPER 
215:  
216: DOUBLE PRECISION LOWERBOUND, UPPERBOUND, VECTOR(3), WIDTH 
217: INTEGER I,IDNUM,NODEITER 
218:  
219: DO I=1,NITER 
220:  
221:     CALL QUEUEGET(LOWERBOUND, UPPERBOUND, VECTOR, WIDTH, NODEITER, IDNUM) 
222:  
223:     IF(DEBUG.AND.(IPRINT.GT.0).AND.(MOD(I,IPRINT).EQ.0)) THEN 
224:         WRITE(*,'(A)') & 
225:          & "gopermdist> -----------------STATUS UPDATE----------------" 
226:         WRITE(*,'(A,I16)') & 
227:          & "gopermdist> iteration  number           = ", I 
228:         WRITE(*,'(A,G20.6)') & 
229:          & "gopermdist> lowest upper bound so far   = ", BESTUPPER 
230:         WRITE(*,'(A,G20.6)') & 
231:          & "gopermdist> highest lower bound so far  = ", LOWERBOUND 
232:         WRITE(*,'(A,I16)') & 
233:          & "gopermdist> total calculations so far   = ", NCALC 
234:         WRITE(*,'(A,I16)') & 
235:          & "gopermdist> queue length                = ", QUEUELEN() 
236:         WRITE(*,'(A)') & 
237:          & "gopermdist> ----------------------------------------------" 
238:     ENDIF 
239:  
240:     CALL BRANCH(VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE) 
241:  
242:     IF(QUEUELEN().LE.0) THEN 
243:         IF(DEBUG) WRITE(*,'(A)') & 
244:              & "gopermdist> priority queue empty, stopping" 
245:     END IF 
246:  
247:     IF((QUEUELEN().LE.0).OR.((LOWERBOUND).GT.(BESTUPPER - RTOL*BESTUPPER - ATOL))) THEN 
248:         IF(DEBUG) THEN 
249:             WRITE(*,'(A)') & 
250:              & "gopermdist> -------------------SUCCESS--------------------" 
251:             WRITE(*,'(A,G20.6)') & 
252:              & "gopermdist> converged on minimum RMSD   = ", BESTUPPER 
253:             WRITE(*,'(A,I16)') & 
254:              & "gopermdist> total calculations          = ", NCALC 
255:             WRITE(*,'(A,I16)') & 
256:              & "gopermdist> found best on iteration     = ", BESTITER 
257:             WRITE(*,'(A,I16)') & 
258:              & "gopermdist> best structure              = ", BESTID 
259:             WRITE(*,'(A)') & 
260:              & "gopermdist> -------------------SUCCESS--------------------" 
261:         END IF 
262:         EXIT 
263:     END IF 
264:  
265: END DO 
266:  
267: IF (DEBUG.AND.SAVECOORDS) CALL PRINTDISTANCES() 
268:  
269: END SUBROUTINE 
270:  
271: SUBROUTINE ADDNODE(VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE,LOWERBOUND,UPPERBOUND) 
272:  
273: USE ALIGNUTILS, ONLY : ITERATIVEALIGN 
274:  
275: IMPLICIT NONE 
276: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3), WIDTH 
277: DOUBLE PRECISION, INTENT(INOUT) :: BESTUPPER 
278: DOUBLE PRECISION, INTENT(OUT) :: LOWERBOUND, UPPERBOUND 
279: INTEGER, INTENT(IN) :: IDNUM 
280: LOGICAL, INTENT(IN) :: FORCE 
281:  
282: DOUBLE PRECISION :: DIST2 
283:  
284: CALL CALCBOUNDS(LOWERBOUND,UPPERBOUND,VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE) 
285:  
286: ! If upperbound within tolerance of lowest upperbound then quench with 
287: ! minpermdist 
288: IF ((UPPERBOUND).LE.(BESTUPPER + MPRTOL*BESTUPPER + ATOL)) THEN 
289:  
290:     CALL ITERATIVEALIGN(SAVECOORDSB,DUMMYA,NATOMS,DEBUG,BULK_BOXVEC(1),BULK_BOXVEC(2),BULK_BOXVEC(3),BULKT, & 
291:     & DIST2,UPPERBOUND,DUMMYRMAT,DUMMYDISP,PERMBEST) 
292:  
293:     ! Resetting keywords 
294:     NQUENCH = NQUENCH + 1 
295:  
296:     IF(DEBUG) WRITE(*, "(A,G20.5)") & 
297:  & "gopermdist> post quench new lowest RMSD = ", UPPERBOUND 
298: END IF 
299:  
300: IF (UPPERBOUND.LT.BESTUPPER) THEN 
301:     BESTUPPER = UPPERBOUND 
302:  
303:     IF(DEBUG) WRITE(*, "(A,G20.5)") & 
304:  & "gopermdist> NEW lowest upper bound RMSD = ", UPPERBOUND 
305:  
306:     IF (.NOT.BULKT) THEN 
307:         BESTDISP(:,IDNUM) = DUMMYDISP 
308:     ELSE 
309:         BESTRMAT(:,:,IDNUM) = MATMUL(TRMAT,DUMMYRMAT) 
310:     END IF 
311:  
312:     BESTCOORDSA(:,IDNUM) = DUMMYA 
313:     BESTPERMS(:,IDNUM) = PERMBEST 
314:     BESTID = IDNUM 
315:     BESTITER = NCALC 
316:     CALL QUEUEPUT(LOWERBOUND,UPPERBOUND,VECTOR,WIDTH,NCALC,IDNUM) 
317: ELSE IF( (LOWERBOUND ).LT.(BESTUPPER - RTOL*BESTUPPER - ATOL) ) THEN 
318:     CALL QUEUEPUT(LOWERBOUND,UPPERBOUND,VECTOR,WIDTH,NCALC,IDNUM) 
319: END IF 
320:  
321: END SUBROUTINE ADDNODE 
322:  
323:  
324: SUBROUTINE BRANCH(VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE) 
325:  
326: USE ALIGNUTILS, ONLY : TWOD 
327:  
328: IMPLICIT NONE 
329: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3), WIDTH 
330: DOUBLE PRECISION, INTENT(INOUT) :: BESTUPPER 
331: INTEGER, INTENT(IN) :: IDNUM 
332: LOGICAL, INTENT(IN) :: FORCE 
333:  
334: DOUBLE PRECISION :: LOWERBOUND, UPPERBOUND, NEWVECT(3),MINR 
335:  
336: INTEGER I 
337:  
338: IF (BULKT.AND.TWOD) THEN 
339:     ! If 2D then only need to test 4 search cubes 
340:     DO I=1,4 
341:         NEWVECT(:) = VECTOR + TWODVECS(:,I)*WIDTH*0.25D0 
342:         ! Check if displacement is within lattice cell 
343:         IF( ((BULK_BOXVEC(1)/2-ABS(NEWVECT(1))+WIDTH*0.25D0).GT.0.D0).AND. & 
344:           & ((BULK_BOXVEC(2)/2-ABS(NEWVECT(2))+WIDTH*0.25D0).GT.0.D0) ) CALL ADDNODE( & 
345:           & NEWVECT,WIDTH*0.5D0,IDNUM,BESTUPPER,FORCE,LOWERBOUND,UPPERBOUND) 
346:     END DO 
347: ELSE 
348:     DO I=1,8 
349:         NEWVECT(:) = VECTOR + LVECS(:,I)*WIDTH*0.25D0 
350:         IF(BULKT) THEN 
351:             ! Check if displacement is within lattice cell 
352:             IF( ((BULK_BOXVEC(1)/2-ABS(NEWVECT(1))+WIDTH*0.25D0).GT.0.D0).AND. & 
353:               & ((BULK_BOXVEC(2)/2-ABS(NEWVECT(2))+WIDTH*0.25D0).GT.0.D0).AND. & 
354:               & ((BULK_BOXVEC(3)/2-ABS(NEWVECT(2))+WIDTH*0.25D0).GT.0.D0) ) CALL ADDNODE( & 
355:               & NEWVECT,WIDTH*0.5D0,IDNUM,BESTUPPER,FORCE,LOWERBOUND,UPPERBOUND) 
356:         ! Check if rotation is within sphere 
357:         ELSE IF ((SUM(NEWVECT**2)-0.75D0*WIDTH**2).LE.(PI**2)) THEN 
358:             CALL ADDNODE(NEWVECT,WIDTH*0.5D0,IDNUM,BESTUPPER,FORCE,LOWERBOUND,UPPERBOUND) 
359:         END IF 
360:     END DO 
361: END IF 
362:  
363: END SUBROUTINE BRANCH 
364:  
365: SUBROUTINE CALCBOUNDS(LOWERBOUND,UPPERBOUND,VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE) 
366:  
367: USE ALIGNUTILS, ONLY : PERMPAIRDISTS, FINDBESTPERM 
368:  
369: IMPLICIT NONE 
370: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3), WIDTH, BESTUPPER 
371: INTEGER, INTENT(IN) :: IDNUM 
372: LOGICAL, INTENT(IN) :: FORCE 
373:  
374: DOUBLE PRECISION, INTENT(OUT) :: LOWERBOUND, UPPERBOUND 
375:  
376: DOUBLE PRECISION W,SINW,COSW,RA,RB,ESTLOWER,ESTUPPER,D,V,COSP 
377: INTEGER I,J,J1,M,K,K1,IND,NDUMMY,NPERM,INFO,IA,IB 
378: LOGICAL RECALC 
379:  
380: !DOUBLE PRECISION PERMDIST 
381:  
382: IF(BULKT) THEN 
383:     W = SQRT(3.D0) * WIDTH * 0.5D0 
384: ELSE 
385:     V = SQRT(SUM(VECTOR**2)) 
386:     COSP = V/SQRT(V**2 + 0.75*WIDTH**2) 
387:     !COSP = (V-WIDTH*0.5D0)/SQRT(V**2 - V*WIDTH + 0.5*WIDTH**2) 
388:     COSW = MIN(COS(WIDTH*0.5D0), (COS(V)**2 + COSP*SIN(V)**2) * COS(WIDTH*0.5D0) - & 
389:      & (1-COSP)*ABS(SIN(V)*COS(V)*SIN(WIDTH*0.5D0)) ) 
390: !    COSW = COS(W) 
391:     SINW = SQRT(1.D0 - COSW**2) 
392: END IF 
393:  
394: IF(DEBUG) THEN 
395:     IF(BULKT) WRITE(*, "(A,3F16.5)") & 
396:  & "gopermdist> testing displacement vector = ", VECTOR 
397:     IF(.NOT.BULKT) WRITE(*, "(A,3F16.5)") & 
398:  & "gopermdist> testing angle-axis vector   = ", VECTOR 
399:     WRITE(*, "(A,G20.5,A,I4)") & 
400:  & "gopermdist> with width                  = ", WIDTH, & 
401:  & "     on IDNUM    =", IDNUM 
402: END IF 
403:  
404: CALL TRANSFORM(DUMMYA, NATOMS, VECTOR, IDNUM) 
405:  
406: ! Find distance matrix 
407:  
408: CALL PERMPAIRDISTS(SAVECOORDSB,DUMMYA,NATOMS,PMAXNEI,DUMMYDISTS,DUMMYIDX,NPERMGROUP) 
409:  
410: ! Find bounded distanace matrix 
411: IF(BULKT) THEN 
412:     NDUMMY=0 
413:     DO J1=1,NPERMGROUP 
414:         NPERM=NPERMSIZE(J1) 
415:         M = MIN(NPERM,PMAXNEI) 
416:         DUMMYLDISTS(:NPERM*M,J1) = MAX(SQRT(DUMMYDISTS(:NPERM*M,J1)) - W,0.D0)**2 
417:     ENDDO 
418: ELSE 
419:     NDUMMY=0 
420:     DO J1=1,NPERMGROUP 
421:         NPERM = NPERMSIZE(J1) 
422:         M = MIN(NPERM,PMAXNEI) 
423:         DO J=1,NPERM 
424:             K=M*(J-1) 
425:             RB = SAVERB(PERMGROUP(J+NDUMMY)) 
426:             DO I=1,M 
427:                 IND = K+I 
428:                 RA = SAVERA(PERMGROUP(DUMMYIDX(IND,J1)+NDUMMY),IDNUM) 
429:                 DUMMYLDISTS(IND,J1) = BOUNDROTDISTANCE( & 
430:                      & DUMMYDISTS(IND,J1),COSW,SINW,RB,RA) 
431:             END DO 
432:         ENDDO 
433:     NDUMMY = NDUMMY + NPERMSIZE(J1) 
434:     ENDDO 
435: END IF 
436:  
437: ! Estimating upperbound by finding nearest neighbours 
438: IF((.NOT.FORCE).OR.DEBUG) THEN 
439:     CALL PERMNEARESTNEIGHBOURDISTS(DUMMYDISTS,DUMMYIDX,NATOMS,PMAXNEI, & 
440:      & DUMMYNEARIDX,DUMMYNEARDISTS,NPERMGROUP) 
441:  
442:     UPPERBOUND = SUM(DUMMYNEARDISTS)**0.5 
443:     IF(DEBUG) WRITE(*, "(A,G20.5,A)") & 
444:  & "gopermdist> estimate for upper bound    = ", UPPERBOUND 
445:  
446:     ! Check if permutation has been found anyway 
447:     IF(UPPERBOUND.LT.BESTUPPER) THEN 
448:         LPERM = 0 
449:         DO J1=1,NATOMS 
450:             LPERM(DUMMYNEARIDX(J1)) = 1 
451:         END DO 
452:         IF(ALL(LPERM.EQ.1)) THEN 
453:             RECALC = .FALSE. 
454:             IF(DEBUG) WRITE(*, "(A)") & 
455:  & "gopermdist> nearest neighbours are best permutation" 
456:         ELSE 
457:             RECALC = .TRUE. 
458:         END IF 
459:     ELSE 
460:         RECALC = .FALSE. 
461:     END IF 
462:     ESTUPPER = UPPERBOUND 
463: END IF 
464:  
465:  
466: ! Estimating Lower Bound by finding nearest neighbours 
467: IF(DEBUG.OR.(.NOT.(FORCE.OR.RECALC))) THEN 
468:     IF(BULKT) THEN 
469:  
470:         ! Find relative displacements 
471:         DO J1=1,NPERMGROUP 
472:             NPERM=NPERMSIZE(J1) 
473:             M = MIN(NPERM,PMAXNEI) 
474:             DO I=1,NPERM 
475:                 IB = PERMGROUP(I+NDUMMY) 
476:                 K = M*(I-1) 
477:                 DO J=1,M 
478:                     IA = PERMGROUP(DUMMYIDX(K+J,J1)+NDUMMY) 
479:                     DUMMYDISPS(:,K+J,J1) = SAVECOORDSB(3*IB-2:3*IB) - DUMMYA(3*IA-2:3*IA) 
480:                     DUMMYDISPS(1,K+J,J1) = DUMMYDISPS(1,K+J,J1) - & 
481:                      & NINT(DUMMYDISPS(1,K+J,J1)/BULK_BOXVEC(1)) * BULK_BOXVEC(1) 
482:                     DUMMYDISPS(2,K+J,J1) = DUMMYDISPS(2,K+J,J1) - & 
483:                      & NINT(DUMMYDISPS(2,K+J,J1)/BULK_BOXVEC(2)) * BULK_BOXVEC(2) 
484:                     DUMMYDISPS(3,K+J,J1) = DUMMYDISPS(3,K+J,J1) - & 
485:                      & NINT(DUMMYDISPS(3,K+J,J1)/BULK_BOXVEC(3)) * BULK_BOXVEC(3) 
486:  
487:                     DUMMYDOTDISP(:,K+J,J1) = MATMUL(DUMMYDISPS(:,K+J,J1),LVECS(:,1:4)) 
488:                 END DO 
489:             END DO 
490:             NDUMMY = NDUMMY + NPERM 
491:         END DO 
492:  
493:         ESTLOWER = HUGE(1.D0) 
494:         DO I=1,6 
495:             DO J1=1,NPERMGROUP 
496:                 NPERM=NPERMSIZE(J1) 
497:                 M = MIN(NPERM,PMAXNEI) 
498:                 DUMMYLDISTS2(:M*NPERM,J1) = MERGE(DUMMYDISTS(:M*NPERM,J1), & 
499:                                                 & DUMMYLDISTS(:M*NPERM,J1), & 
500:                  & MATMUL(FVECS(:,I),DUMMYDOTDISP(:,:M*NPERM,J1)).GT.0.D0) 
501:             END DO 
502:  
503:             CALL PERMNEARESTNEIGHBOURDISTS(DUMMYLDISTS2,DUMMYIDX,NATOMS, & 
504:              & PMAXNEI,DUMMYNEARIDX,DUMMYNEARLDISTS,NPERMGROUP) 
505:  
506:             D = SUM(DUMMYNEARLDISTS) 
507:             ESTLOWER = MIN(D, ESTLOWER) 
508:  
509:             IF(DEBUG) WRITE(*, "(A,I16,A,G10.3)") & 
510:      & "gopermdist> estimating for face         = ", I, & 
511:      & "         lower bound = ", D**0.5 
512:         END DO 
513:         ESTLOWER = SQRT(ESTLOWER) 
514:  
515:     ELSE 
516:         CALL PERMNEARESTNEIGHBOURDISTS(DUMMYLDISTS,DUMMYIDX,NATOMS,PMAXNEI, & 
517:          & DUMMYNEARIDX,DUMMYNEARLDISTS,NPERMGROUP) 
518:  
519:         ESTLOWER = SUM(DUMMYNEARLDISTS)**0.5 
520:     END IF 
521:  
522:     LOWERBOUND = ESTLOWER 
523:  
524:     IF(DEBUG) WRITE(*, "(A,G20.5)") & 
525:      & "gopermdist> estimate for lower bound    = ", ESTLOWER 
526:  
527: END IF 
528:  
529:  
530: ! If estimate of upperbound is lower than best found upperbound we need to 
531: ! solve assignment problem to find bounds 
532: IF (FORCE.OR.RECALC) THEN 
533:  
534:     ! Need to calculate this matrix to get total distance from reduced distance 
535:     ! matrix and total permutation 
536:     CALL INVPAIRDISTIDX(DUMMYIDX, DINVIDX, NATOMS, PMAXNEI, NPERMGROUP) 
537:  
538:     IF(BULKT) THEN 
539:         DO J1=1,NPERMGROUP 
540:             NPERM=NPERMSIZE(J1) 
541:             M = MIN(NPERM,PMAXNEI) 
542:             DUMMYLDISTS(:NPERM*M,J1) = MAX(SQRT(DUMMYDISTS(:NPERM*M,J1)) - W,0.D0)**2 
543:         ENDDO 
544:     END IF 
545:  
546:     CALL FINDBESTPERM(DUMMYLDISTS,DUMMYIDX,NATOMS,PMAXNEI,NEWPERM, & 
547:      & LOWERBOUND,NPERMGROUP, INFO) 
548:  
549:     CALL FINDPERMVAL(NEWPERM,NATOMS,DUMMYLDISTS,DINVIDX,PMAXNEI,NPERMGROUP,LOWERBOUND) 
550:  
551:     ! Check output of assignment problem 
552:     IF(INFO.GT.0) THEN 
553:         LOWERBOUND = 0.D0 
554:         IF(DEBUG) WRITE(*, "(A,I3)") & 
555:  & "gopermdist> WARNING LAP algorithm failed to align npoints= ", INFO 
556:     ELSE 
557:         LOWERBOUND = SQRT(LOWERBOUND) 
558:         IF(DEBUG) WRITE(*, "(A,G20.5)") & 
559:  & "gopermdist> calculated lower bound RMSD = ", LOWERBOUND 
560:     END IF 
561:     ! Calculate upperbound if lowerbound lower than bestupper 
562:     IF((LOWERBOUND.LT.BESTUPPER).OR.FORCE) THEN 
563:         CALL FINDBESTPERM(DUMMYDISTS,DUMMYIDX,NATOMS,PMAXNEI,LPERM, & 
564:          & UPPERBOUND,NPERMGROUP, INFO) 
565:  
566:         CALL FINDPERMVAL(LPERM,NATOMS,DUMMYDISTS,DINVIDX,PMAXNEI,NPERMGROUP,UPPERBOUND) 
567:  
568:         ! Check output of assignment problem 
569:         IF(INFO.GT.0) THEN 
570:             UPPERBOUND = HUGE(1.D0) 
571:             IF(DEBUG) WRITE(*, "(A,I3)") & 
572:  & "gopermdist> WARNING LAP algorithm failed to align npoints= ", INFO 
573:         ELSE 
574:             UPPERBOUND = SQRT(UPPERBOUND) 
575:             IF(DEBUG) WRITE(*, "(A,G20.5)") & 
576:  & "gopermdist> calculated upper bound RMSD = ", UPPERBOUND 
577:         END IF 
578:     ELSE 
579:         UPPERBOUND = HUGE(1.D0) 
580:     END IF 
581: END IF 
582:  
583: IF (DEBUG.AND.((ESTUPPER.GT.UPPERBOUND).OR.(ESTLOWER.GT.LOWERBOUND))) THEN 
584:     WRITE(*,"(A)") "gopermdist>************WARNING*********************" 
585:     WRITE(*,"(A)") "EST UPPER GT UPPERBOUND OR EST LOWER GT LOWERBOUND" 
586:     WRITE(*,"(A)") "gopermdist>************WARNING*********************" 
587:     NBAD = NBAD + 1 
588: ENDIF 
589:  
590: NCALC = NCALC + 1 
591:  
592: END SUBROUTINE CALCBOUNDS 
593:  
594: SUBROUTINE FINDPERMVAL(PERM, NCOORDS, MATVALS, DINVIDX, MAXNEI, NPERMGROUPS, BEST) 
595:  
596: IMPLICIT NONE 
597: INTEGER, INTENT(IN) :: NCOORDS, MAXNEI, NPERMGROUPS 
598: INTEGER, INTENT(IN) :: PERM(NCOORDS), DINVIDX(NCOORDS*NCOORDS,NPERMGROUPS) 
599: DOUBLE PRECISION, INTENT(IN) :: MATVALS(NCOORDS*MAXNEI,NPERMGROUPS) 
600: DOUBLE PRECISION, INTENT(OUT) :: BEST 
601:  
602: INTEGER J1,M,J,I,IA,NPERM,NDUMMY 
603:  
604: IF (NPERMGROUP.NE.NPERMGROUPS) THEN 
605:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
606:     STOP 
607: ENDIF 
608:  
609: BEST = 0.D0 
610: NDUMMY = 0 
611: DO J1=1,NPERMGROUP 
612:     NPERM = NPERMSIZE(J1) 
613:     M = MIN(NPERM,MAXNEI) 
614:     DO J=1,NPERM 
615:         IA = INVPERMGROUP(PERM(PERMGROUP(J+NDUMMY)))-NDUMMY 
616:         I = DINVIDX(NPERM*(J-1)+IA,J1) 
617:         BEST = BEST + MATVALS(M*(J-1)+I,J1) 
618:     END DO 
619:     NDUMMY = NDUMMY + NPERM 
620: END DO 
621:  
622: END SUBROUTINE FINDPERMVAL 
623:  
624: SUBROUTINE INVPAIRDISTIDX(DUMMYIDX, DINVIDX, NCOORDS, MAXNEI, NPERMGROUPS) 
625:  
626: IMPLICIT NONE 
627: INTEGER, INTENT(IN) :: NCOORDS, MAXNEI, NPERMGROUPS 
628: INTEGER, INTENT(IN) :: DUMMYIDX(NCOORDS*MAXNEI,NPERMGROUPS) 
629: INTEGER, INTENT(OUT) :: DINVIDX(NCOORDS*NCOORDS,NPERMGROUPS) 
630: INTEGER J1,NPERM,I,J,M 
631:  
632: IF (NPERMGROUP.NE.NPERMGROUPS) THEN 
633:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
634:     STOP 
635: ENDIF 
636:  
637: DINVIDX = -1 
638: DO J1=1,NPERMGROUP 
639:     NPERM = NPERMSIZE(J1) 
640:     M = MIN(NPERM,MAXNEI) 
641:     DO J=1,NPERM 
642:         DO I=1,M 
643:             DINVIDX(NPERM*(J-1)+DUMMYIDX(M*(J-1)+I,J1),J1) = I 
644:         END DO 
645:     END DO 
646: END DO 
647:  
648: END SUBROUTINE INVPAIRDISTIDX 
649:  
650: SUBROUTINE PERMNEARESTNEIGHBOURDISTS(NDISTS,NIDX,NCOORDS,MAXNEI,NEARI,NEARD,NPERMGROUPS) 
651:  
652: IMPLICIT NONE 
653: INTEGER, INTENT(IN) :: NCOORDS,MAXNEI,NPERMGROUPS,NIDX(MAXNEI*NCOORDS,NPERMGROUPS) 
654: DOUBLE PRECISION, INTENT(IN) :: NDISTS(MAXNEI*NCOORDS,NPERMGROUPS) 
655:  
656: INTEGER, INTENT(OUT) :: NEARI(NCOORDS) 
657: DOUBLE PRECISION, INTENT(OUT) :: NEARD(NCOORDS) 
658:  
659: INTEGER I, J1, J2, IND, NPERM, NDUMMY, M 
660:  
661: IF (NPERMGROUP.NE.NPERMGROUPS) THEN 
662:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
663:     STOP 
664: ENDIF 
665:  
666: NDUMMY = 0 
667: DO J1=1,NPERMGROUP 
668:     NPERM=NPERMSIZE(J1) 
669: !    M = MERGE(NPERM,MAXNEI,NPERM.LT.MAXNEI) 
670:     M = MIN(NPERM,PMAXNEI) 
671:     CALL NEARESTNEIGHBOURDISTS(NDISTS(1:NPERM*M,J1),NIDX(1:NPERM*M,J1), & 
672:  & NPERM,M,LPERM(1:NPERM),PDUMMYND(1:NPERM)) 
673:  
674:     DO J2=1,NPERM 
675:         IND = LPERM(J2) 
676:         NEARI(PERMGROUP(NDUMMY+J2)) = PERMGROUP(NDUMMY + IND) 
677:         NEARD(PERMGROUP(NDUMMY+J2)) = PDUMMYND(J2) 
678:     END DO 
679:     NDUMMY = NDUMMY + NPERM 
680: END DO 
681:  
682: END SUBROUTINE PERMNEARESTNEIGHBOURDISTS 
683:  
684: SUBROUTINE NEARESTNEIGHBOURDISTS(CC, KK, N, MAXNEI, IDX, DISTS) 
685:  
686: IMPLICIT NONE 
687:  
688: INTEGER, INTENT(IN) :: N, MAXNEI, KK(MAXNEI*N) 
689: DOUBLE PRECISION, INTENT(IN) :: CC(MAXNEI*N) 
690:  
691: INTEGER, INTENT(OUT) :: IDX(N) 
692: DOUBLE PRECISION, INTENT(OUT) :: DISTS(N) 
693:  
694: INTEGER I,J,K,M 
695:  
696: M=MAXNEI 
697: IF(N.LT.MAXNEI) M=N 
698:  
699: DO I=1,N 
700:     J = MINLOC(CC(M*(I-1)+1:M*I),1) 
701:     DISTS(I) = CC(M*(I-1) + J) 
702:     IDX(I)   = KK(M*(I-1) + J) 
703: END DO 
704:  
705: END SUBROUTINE NEARESTNEIGHBOURDISTS 
706:  
707: FUNCTION BOUNDROTDISTANCE(D2,COSW,SINW,RA,RB) RESULT(LDIST) 
708:  
709: IMPLICIT NONE 
710: DOUBLE PRECISION, INTENT(IN) :: D2,COSW,SINW,RA,RB 
711: DOUBLE PRECISION LDIST 
712:  
713: DOUBLE PRECISION RARB,RA2RB2,COSAB,SINAB,MCOSAB 
714:  
715: ! Precalculate these? 
716: RARB = 2*RA*RB 
717: RA2RB2 = RA**2 + RB**2 
718:  
719: COSAB = (RA2RB2 - D2)/RARB 
720: SINAB = SQRT(1.D0-MIN(COSAB**2,1.D0)) ! Making sure sqrt is of positive number 
721: MCOSAB = MERGE(1.D0, COSAB*COSW + SINAB*SINW, COSAB.GT.COSW) 
722:  
723: LDIST = MAX(RA2RB2 - RARB*MCOSAB,0.D0) 
724:  
725: END FUNCTION 
726:  
727: FUNCTION QUEUELEN() RESULT(LENGTH) 
728:  
729: IMPLICIT NONE 
730: INTEGER LENGTH 
731:  
732: LENGTH = Q%N 
733:  
734: END FUNCTION 
735:  
736: SUBROUTINE QUEUEGET(LOWERBOUND, UPPERBOUND, VECTOR, WIDTH, NITER, IDNUM) 
737: USE PRIORITYQUEUE, ONLY: NODE, TOP 
738:  
739: IMPLICIT NONE 
740: DOUBLE PRECISION, INTENT(OUT) :: lowerbound, upperbound, vector(3), width 
741: INTEGER, INTENT(OUT) :: niter, IDNUM 
742:  
743: TYPE(NODE) RES 
744:  
745: IF(Q%N.GT.0) THEN 
746:     RES = TOP(Q) 
747:     VECTOR = RES%VECTOR 
748:     UPPERBOUND = RES%UPPERBOUND 
749:     LOWERBOUND = RES%LOWERBOUND 
750:     WIDTH = RES%WIDTH 
751:     NITER = RES%NITER 
752:     IDNUM = RES%IDNUM 
753: ELSE IF(DEBUG) THEN 
754:     WRITE(*,"(A)") "gopermdist> warning, trying to read empty list" 
755: ENDIF 
756:  
757: END SUBROUTINE QUEUEGET 
758:  
759: SUBROUTINE QUEUEPUT(LOWERBOUND, UPPERBOUND, VECTOR, WIDTH, NITER, IDNUM) 
760: USE PRIORITYQUEUE, ONLY: ENQUEUE 
761:  
762: IMPLICIT NONE 
763:  
764: DOUBLE PRECISION, INTENT(IN) :: lowerbound, upperbound, vector(3), width 
765: INTEGER, INTENT(IN) :: niter, IDNUM 
766:  
767: CALL ENQUEUE(Q, LOWERBOUND, UPPERBOUND, VECTOR, WIDTH, NITER, IDNUM) 
768:  
769: END SUBROUTINE QUEUEPUT 
770:  
771: SUBROUTINE QUEUECLEAR() 
772: USE PRIORITYQUEUE, ONLY: NODE, TOP 
773:  
774: IMPLICIT NONE 
775: TYPE(NODE) RES 
776:  
777: DO WHILE(Q%N.GT.0) 
778:     RES = TOP(Q) 
779: END DO 
780:  
781: END SUBROUTINE QUEUECLEAR 
782:  
783: SUBROUTINE INITIALISE(COORDSB,COORDSA,NCOORDS,NBOXLX,NBOXLY,NBOXLZ,NBULKT) 
784:  
785: USE ALIGNUTILS, ONLY: OHOPS 
786:  
787: IMPLICIT NONE 
788:  
789: INTEGER, INTENT(IN) :: NCOORDS 
790: DOUBLE PRECISION, INTENT(IN) :: COORDSB(3*NCOORDS), COORDSA(3*NCOORDS), & 
791:  & NBOXLX, NBOXLY, NBOXLZ 
792: LOGICAL, INTENT(IN) :: NBULKT 
793:  
794: DOUBLE PRECISION BVEC(3) 
795: INTEGER I, J, K, IND, NUMSTRUCTS 
796:  
797: NATOMS = NCOORDS 
798: BOXVEC = (/NBOXLX,NBOXLY,NBOXLZ/) 
799: BULKT = NBULKT 
800:  
801: NCALC   = 0 
802: NLAP    = 0 
803: NQUENCH = 0 
804: NBAD = 0 
805:  
806: ! --------------------------------------------------------------------------- ! 
807: !    allocating memory to arrays 
808: ! --------------------------------------------------------------------------- ! 
809:  
810: NUMSTRUCTS = 1 
811: IF ((.NOT.NOINVERSION)) NUMSTRUCTS = 2 
812: IF (BULKT.AND.OHCELLT) NUMSTRUCTS = 48 
813:  
814:  
815: CALL REALLOCATEARRAYS(NATOMS, NUMSTRUCTS, BULKT) 
816:  
817: ! --------------------------------------------------------------------------- ! 
818: !    calculate inverse permutation group 
819: ! --------------------------------------------------------------------------- ! 
820:  
821: DO I=1,NATOMS 
822:     INVPERMGROUP(PERMGROUP(I)) = I 
823: END DO 
824:  
825: ! --------------------------------------------------------------------------- ! 
826: !    storing coordinates to module 
827: ! --------------------------------------------------------------------------- ! 
828:  
829: IF(BULKT) THEN 
830:     SAVECOORDSB = COORDSB 
831:     IF(OHCELLT) THEN 
832:         DO I=1,48 
833:             CALL OHOPS(COORDSA,SAVECOORDSA(:,I),I,NATOMS) 
834:         END DO 
835:     ELSE 
836:         SAVECOORDSA(:,1) = COORDSA 
837:     END IF 
838: ELSE 
839:     ! Calculate COM 
840:     DO J=1,NATOMS 
841:         CMAX=CMAX+COORDSA(3*(J-1)+1) 
842:         CMAY=CMAY+COORDSA(3*(J-1)+2) 
843:         CMAZ=CMAZ+COORDSA(3*(J-1)+3) 
844:     ENDDO 
845:     CMAX=CMAX/NATOMS; CMAY=CMAY/NATOMS; CMAZ=CMAZ/NATOMS 
846:     CMBX=0.0D0; CMBY=0.0D0; CMBZ=0.0D0 
847:     DO J=1,NATOMS 
848:         CMBX=CMBX+COORDSB(3*(J-1)+1) 
849:         CMBY=CMBY+COORDSB(3*(J-1)+2) 
850:         CMBZ=CMBZ+COORDSB(3*(J-1)+3) 
851:     ENDDO 
852:     CMBX=CMBX/NATOMS; CMBY=CMBY/NATOMS; CMBZ=CMBZ/NATOMS 
853:  
854:     ! Save COM centred coordinates 
855:     DO I=1,NATOMS 
856:         SAVECOORDSB(3*I-2) = COORDSB(3*I-2) - CMBX 
857:         SAVECOORDSB(3*I-1) = COORDSB(3*I-1) - CMBY 
858:         SAVECOORDSB(3 * I) = COORDSB(3 * I) - CMBZ 
859:         SAVERB(I) = SQRT(SAVECOORDSB(3*I-2)**2+SAVECOORDSB(3*I-1)**2+ & 
860:                        & SAVECOORDSB(3 * I)**2) 
861:     ENDDO 
862:     DO I=1,NATOMS 
863:         SAVECOORDSA(3*I-2,1) = COORDSA(3*I-2) - CMAX 
864:         SAVECOORDSA(3*I-1,1) = COORDSA(3*I-1) - CMAY 
865:         SAVECOORDSA(3 * I,1) = COORDSA(3 * I) - CMAZ 
866:         SAVERA(I,1) = SQRT(SAVECOORDSA(3*I-2,1)**2+SAVECOORDSA(3*I-1,1)**2+ & 
867:                          & SAVECOORDSA(3 * I,1)**2) 
868:     ENDDO 
869:     ! Store inverted configuration 
870:     IF (.NOT.NOINVERSION) THEN 
871:         SAVECOORDSA(:,2) = -SAVECOORDSA(:,1) 
872:         SAVERA(:,2) = SAVERA(:,1) 
873:     END IF 
874: END IF 
875:  
876: CALL QUEUECLEAR() 
877:  
878: END SUBROUTINE INITIALISE 
879:  
880: SUBROUTINE SETNATOMS(NEWNATOMS) 
881: ! Checks if arrays need to be (re)allocated 
882: IMPLICIT NONE 
883:  
884: INTEGER, INTENT(IN) :: NEWNATOMS 
885:  
886: IF(.NOT.(SIZE(PDUMMYA).EQ.(3*NEWNATOMS))) THEN 
887:     IF(ALLOCATED(PDUMMYA)) THEN 
888:         DEALLOCATE(PDUMMYA,PDUMMYB,DUMMYA,DUMMYB,XBESTA,XBESTASAVE) 
889:         DEALLOCATE(NEWPERM, LPERM) 
890:     ENDIF 
891:     ALLOCATE(PDUMMYA(3*NEWNATOMS),PDUMMYB(3*NEWNATOMS),DUMMYA(3*NEWNATOMS), & 
892:     &   DUMMYB(3*NEWNATOMS), XBESTA(3*NEWNATOMS), XBESTASAVE(3*NEWNATOMS)) 
893:     ALLOCATE(NEWPERM(NEWNATOMS), LPERM(NEWNATOMS)) 
894: ENDIF 
895:  
896: END SUBROUTINE SETNATOMS 
897:  
898: SUBROUTINE SETPERM(NEWNATOMS, NEWPERMGROUP, NEWNPERMSIZE) 
899: ! Not needed for GMIN/OPTIM/PATHSAMPLE 
900: ! (Re)allocates arrays that define allowed permuations 
901: IMPLICIT NONE 
902:  
903: INTEGER, INTENT(IN) :: NEWNATOMS, NEWPERMGROUP(:), NEWNPERMSIZE(:) 
904:  
905: IF(.NOT.SIZE(PERMGROUP).EQ.SIZE(NEWPERMGROUP)) THEN 
906:     IF(ALLOCATED(PERMGROUP)) THEN 
907:         DEALLOCATE(PERMGROUP) 
908:     ENDIF 
909:     ALLOCATE(PERMGROUP(SIZE(NEWPERMGROUP))) 
910: ENDIF 
911:  
912: NPERMGROUP = SIZE(NEWNPERMSIZE) 
913: IF(.NOT.SIZE(NPERMSIZE).EQ.SIZE(NEWNPERMSIZE)) THEN 
914:     IF(ALLOCATED(NPERMSIZE)) THEN 
915:         DEALLOCATE(NPERMSIZE) 
916:     ENDIF 
917:     ALLOCATE(NPERMSIZE(NPERMGROUP)) 
918: ENDIF 
919:  
920: IF(.NOT.SIZE(BESTPERM).EQ.NEWNATOMS) THEN 
921:     IF(ALLOCATED(BESTPERM)) THEN 
922:         DEALLOCATE(BESTPERM) 
923:     ENDIF 
924:     ALLOCATE(BESTPERM(NEWNATOMS)) 
925: ENDIF 
926:  
927: IF(.NOT.SIZE(NSETS).EQ.(3*NEWNATOMS)) THEN 
928:     IF(ALLOCATED(NSETS)) THEN 
929:         DEALLOCATE(NSETS) 
930:     ENDIF 
931:     ALLOCATE(NSETS(3*NEWNATOMS)) 
932: ENDIF 
933:  
934: IF(.NOT.SIZE(SETS).EQ.(3*NEWNATOMS*70)) THEN 
935:     IF(ALLOCATED(SETS)) THEN 
936:         DEALLOCATE(SETS) 
937:     ENDIF 
938:     ALLOCATE(SETS(3*NEWNATOMS,70)) 
939: ENDIF 
940:  
941: CALL SETNATOMS(NEWNATOMS) 
942:  
943: NATOMS = NEWNATOMS 
944: PERMGROUP = NEWPERMGROUP 
945: NPERMSIZE = NEWNPERMSIZE 
946: NSETS = 0 
947:  
948: END SUBROUTINE SETPERM 
949:  
950: SUBROUTINE TRANSFORM(NEWCOORDSA, NATOMS, VECTOR, IDNUM) 
951:  
952: IMPLICIT NONE 
953: INTEGER, INTENT(IN) :: NATOMS, IDNUM 
954: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3) 
955:  
956: DOUBLE PRECISION, INTENT(OUT) :: NEWCOORDSA(3*NATOMS) 
957:  
958: INTEGER I 
959:  
960: IF(BULKT) THEN 
961:     DO I=1,NATOMS 
962:         NEWCOORDSA(3*I-2) = SAVECOORDSA(3*I-2,IDNUM) - VECTOR(1) 
963:         NEWCOORDSA(3*I-1) = SAVECOORDSA(3*I-1,IDNUM) - VECTOR(2) 
964:         NEWCOORDSA(3*I  ) = SAVECOORDSA(3*I  ,IDNUM) - VECTOR(3) 
965:     ENDDO 
966: ELSE 
967:     CALL ANGLEAXIS2MAT(VECTOR, TRMAT) 
968:     DO I=1,NATOMS 
969:         NEWCOORDSA(3*I-2:3*I) = MATMUL(TRMAT,SAVECOORDSA(3*I-2:3*I,IDNUM)) 
970:     ENDDO 
971: ENDIF 
972:  
973: END SUBROUTINE TRANSFORM 
974:  
975: SUBROUTINE ANGLEAXIS2MAT(VECTOR,RMAT) 
976:  
977: IMPLICIT NONE 
978: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3) 
979: DOUBLE PRECISION, INTENT(OUT) :: RMAT(3,3) 
980:  
981: DOUBLE PRECISION THETA,X,Y,Z,S,C,C1,XS,YS,ZS,XC,YC,ZC,XYC,YZC,ZXC 
982:  
983: THETA = SUM((VECTOR**2))**0.5 
984:  
985: IF(THETA.EQ.0.D0) THEN 
986:     RMAT = RESHAPE((/& 
987:      & 1.00000000000D0,  0.0D0,  0.0D0,   & 
988:      & 0.0D0,  1.00000000000D0,  0.0D0,   & 
989:      & 0.0D0,  0.0D0,  1.00000000000D0/), (/3,3/)) 
990: ELSE 
991:     X = VECTOR(1)/THETA; Y = VECTOR(2)/THETA; Z = VECTOR(3)/THETA 
992:     S = SIN(THETA); C = COS(THETA); C1 = 1.D0 - C 
993:     XS = X*S; YS = Y*S; ZS = Z*S 
994:     XC = X*C1; YC = Y*C1; ZC = Z*C1 
995:     XYC = X*YC; YZC = Y*ZC; ZXC = Z*XC 
996:  
997:     RMAT = RESHAPE((/& 
998:      & x * xC + c, xyC + zs, zxC - ys, & 
999:      & xyC - zs, y * yC + c, yzC + xs, & 
1000:      & zxC + ys, yzC - xs, z * zC + c/), (/3,3/)) 
1001: END IF 
1002:  
1003: END SUBROUTINE ANGLEAXIS2MAT 
1004:  
1005: SUBROUTINE MAT2ANGLEAXIS(VECTOR, RMAT) 
1006:  
1007: IMPLICIT NONE 
1008: DOUBLE PRECISION, INTENT(OUT) :: VECTOR(3) 
1009: DOUBLE PRECISION, INTENT(IN) :: RMAT(0:2,0:2) 
1010:  
1011: DOUBLE PRECISION TRACE, THETA 
1012:  
1013: TRACE = RMAT(0,0)+RMAT(1,1)+RMAT(2,2) 
1014: THETA = ACOS(0.5D0*TRACE-0.5D0) 
1015: VECTOR = (/RMAT(2,1)-RMAT(1,2),RMAT(0,2)-RMAT(2,0),RMAT(1,0)-RMAT(0,1)/) 
1016: VECTOR = VECTOR * 0.5D0 * THETA / SIN(THETA) 
1017:  
1018: END SUBROUTINE MAT2ANGLEAXIS 
1019:  
1020: SUBROUTINE REALLOCATEARRAYS(NATOMS, NUMSTRUCTS, BULKT) 
1021:  
1022: USE KEY, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP 
1023: IMPLICIT NONE 
1024:  
1025: INTEGER, INTENT(IN) :: NATOMS, NUMSTRUCTS 
1026: LOGICAL, INTENT(IN) :: BULKT 
1027:  
1028:  
1029: IF((.NOT.ALLOCATED(PERMGROUP)).OR.(.NOT.ALLOCATED(NPERMSIZE))) THEN 
1030:     WRITE(*,'(A)') 'ERROR - permutation arrays not set, use PERMDIST keyword' 
1031:     STOP 
1032: ENDIF 
1033:  
1034: CALL SETNATOMS(NATOMS) 
1035:  
1036: IF (SIZE(SAVECOORDSA).NE.(3*NATOMS*NUMSTRUCTS)) THEN 
1037:     IF(ALLOCATED(SAVECOORDSB))  DEALLOCATE(SAVECOORDSB,SAVECOORDSA) 
1038:     IF(ALLOCATED(SAVERA)) DEALLOCATE(SAVERA,SAVERB,BESTCOORDSA,BESTRMAT, & 
1039:      & BESTDISP,BESTITERS,BESTPERMS) 
1040:     ALLOCATE(SAVECOORDSB(3*NATOMS),SAVECOORDSA(3*NATOMS,NUMSTRUCTS), & 
1041:      & SAVERB(NATOMS),SAVERA(NATOMS,NUMSTRUCTS),BESTCOORDSA(3*NATOMS,NUMSTRUCTS), & 
1042:      & BESTRMAT(3,3,NUMSTRUCTS),BESTDISP(3,NUMSTRUCTS),BESTITERS(NUMSTRUCTS), & 
1043:      & BESTPERMS(NATOMS,NUMSTRUCTS)) 
1044: END IF 
1045:  
1046: IF (SIZE(PDUMMYA).NE.(3*NATOMS)) THEN 
1047:     IF(ALLOCATED(PDUMMYA)) DEALLOCATE(PDUMMYA,PDUMMYB,DUMMYA,DUMMYB) 
1048:     ALLOCATE(PDUMMYA(3*NATOMS),PDUMMYB(3*NATOMS),DUMMYA(3*NATOMS), & 
1049:      & DUMMYB(3*NATOMS)) 
1050: END IF 
1051:  
1052: IF (SIZE(DUMMYLDISTS).NE.(PMAXNEI*NATOMS*NPERMGROUP)) THEN 
1053:     IF(ALLOCATED(DUMMYDISTS)) DEALLOCATE(DUMMYDISTS, DUMMYIDX) 
1054:     IF(ALLOCATED(DUMMYNEARDISTS)) DEALLOCATE(DUMMYNEARDISTS,DINVIDX,DUMMYNEARIDX, & 
1055:      & DUMMYLDISTS,DUMMYNEARLDISTS, DUMMYLDISTS2,DUMMYDOTDISP,DUMMYDISPS,PDUMMYND) 
1056:     ALLOCATE(DUMMYDISTS(PMAXNEI*NATOMS,NPERMGROUP),DUMMYNEARDISTS(NATOMS), & 
1057:      & PDUMMYND(NATOMS),DUMMYIDX(PMAXNEI*NATOMS,NPERMGROUP),DUMMYNEARIDX(NATOMS), & 
1058:      & DINVIDX(NATOMS*NATOMS,NPERMGROUP),DUMMYLDISTS(PMAXNEI*NATOMS,NPERMGROUP), & 
1059:      & DUMMYNEARLDISTS(NATOMS),DUMMYLDISTS2(PMAXNEI*NATOMS,NPERMGROUP), & 
1060:      & DUMMYDISPS(3,NATOMS*PMAXNEI,NPERMGROUP),DUMMYDOTDISP(4,NATOMS*PMAXNEI,NPERMGROUP)) 
1061: END IF 
1062:  
1063: IF (SIZE(INVPERMGROUP).NE.(NATOMS)) THEN 
1064:     IF(ALLOCATED(NEWPERM)) DEALLOCATE(NEWPERM,LPERM) 
1065:     IF(ALLOCATED(INVPERMGROUP)) DEALLOCATE(INVPERMGROUP, PERMBEST) 
1066:     ALLOCATE(NEWPERM(NATOMS), LPERM(NATOMS), PERMBEST(NATOMS), INVPERMGROUP(NATOMS)) 
1067: END IF 
1068:  
1069: END SUBROUTINE REALLOCATEARRAYS 
1070:  
1071: SUBROUTINE DEALLOCATEBNB() 
1072:  
1073: IMPLICIT NONE 
1074:  
1075: IF(ALLOCATED(SAVECOORDSB))  DEALLOCATE(SAVECOORDSB,SAVECOORDSA) 
1076: IF(ALLOCATED(SAVERA)) DEALLOCATE(SAVERA,SAVERB,BESTCOORDSA,BESTRMAT, & 
1077:  & BESTDISP,BESTITERS,BESTPERMS) 
1078: IF(ALLOCATED(PDUMMYA)) DEALLOCATE(PDUMMYA,PDUMMYB,DUMMYA,DUMMYB) 
1079: IF(ALLOCATED(DUMMYDISTS)) DEALLOCATE(DUMMYDISTS, DUMMYIDX) 
1080: IF(ALLOCATED(DUMMYNEARDISTS)) DEALLOCATE(DUMMYNEARDISTS,DINVIDX,DUMMYNEARIDX, & 
1081:  & DUMMYLDISTS,DUMMYNEARLDISTS, DUMMYLDISTS2,DUMMYDOTDISP,DUMMYDISPS,PDUMMYND) 
1082:  
1083: END SUBROUTINE DEALLOCATEBNB 
1084:  
1085: SUBROUTINE SETCLUSTER(INVERT) 
1086:  
1087: IMPLICIT NONE 
1088: LOGICAL, INTENT(IN) :: INVERT 
1089:  
1090: NOINVERSION = .NOT.INVERT 
1091:  
1092: END SUBROUTINE SETCLUSTER 
1093:  
1094: SUBROUTINE SETBULK(INVERT) 
1095:  
1096: IMPLICIT NONE 
1097: LOGICAL, INTENT(IN) :: INVERT 
1098:  
1099: OHCELLT = INVERT 
1100:  
1101: END SUBROUTINE SETBULK 
1102:  
1103: END MODULE 


r33371/CMakeLists.txt 2017-10-04 18:30:09.676205061 +0100 r33370/CMakeLists.txt 2017-10-04 18:30:13.212251706 +0100
109:                 ${DUMMY_QUIP}109:                 ${DUMMY_QUIP}
110:                 ${DUMMY_OPEP} )110:                 ${DUMMY_OPEP} )
111: 111: 
112: # Glob all the sources112: # Glob all the sources
113: file(GLOB OPTIM_LIB_SOURCES *.f113: file(GLOB OPTIM_LIB_SOURCES *.f
114:                             *.f90114:                             *.f90
115:                             *.F115:                             *.F
116:                             *.F90116:                             *.F90
117:                             NEB/*.f90117:                             NEB/*.f90
118:                             CONNECT/*.f90 118:                             CONNECT/*.f90 
119:                             ALIGN/*.f90 
120:                             AMH/amhglobals.f )119:                             AMH/amhglobals.f )
121: #                           sparse/*.f90120: #                           sparse/*.f90
122: #                           sparse/*.c ) 121: #                           sparse/*.c ) 
123: 122: 
124: file(GLOB NOT_OPTIM_SOURCES getparams.f123: file(GLOB NOT_OPTIM_SOURCES getparams.f
125:                             dsygvx.f124:                             dsygvx.f
126:                             amhdummy.f125:                             amhdummy.f
127:                             #                            OPTIM.f 
128:                             porfuncs.f90126:                             porfuncs.f90
129:                             header.f90127:                             header.f90
130:                             optim_quip_wrapper.f90 128:                             optim_quip_wrapper.f90 
131:                             modcudalbfgs.f90129:                             modcudalbfgs.f90
132:                             modcudabfgsts.f90)                           130:                             modcudabfgsts.f90)                           
133: 131: 
134: # Due to a compiler bug in ifort 13.1.3, we can't use -O3 for genrigid.f90132: # Due to a compiler bug in ifort 13.1.3, we can't use -O3 for genrigid.f90
135: # Investigations continue...133: # Investigations continue...
136: # There also seems to be a bug in the compiler which sometimes causes TSLOCATOR to go into an infinite loop instead of returning.134: # There also seems to be a bug in the compiler which sometimes causes TSLOCATOR to go into an infinite loop instead of returning.
137: # This is removed by using O0 optimisation for NEB/output.f90.135: # This is removed by using O0 optimisation for NEB/output.f90.
182: set_target_properties(extralib PROPERTIES COMPILE_DEFINITIONS "${COMPILE_DEFINITIONS};DUMMY_AMBER12;DUMMY_CUDA;__SPARSE")180: set_target_properties(extralib PROPERTIES COMPILE_DEFINITIONS "${COMPILE_DEFINITIONS};DUMMY_AMBER12;DUMMY_CUDA;__SPARSE")
183: 181: 
184: # Make an optim library182: # Make an optim library
185: add_library(optimlib ${OPTIM_LIB_SOURCES})183: add_library(optimlib ${OPTIM_LIB_SOURCES})
186: set_module_dir(optimlib)184: set_module_dir(optimlib)
187: set_module_depends(optimlib extralib)185: set_module_depends(optimlib extralib)
188: set_target_properties(optimlib PROPERTIES LINKER_LANGUAGE "Fortran") 186: set_target_properties(optimlib PROPERTIES LINKER_LANGUAGE "Fortran") 
189: 187: 
190: add_subdirectory(Bowman)188: add_subdirectory(Bowman)
191: 189: 
192: # See notes in GMIN CMakeLists to explain this block 
193: include(${CMAKE_ROOT}/Modules/ExternalProject.cmake) 
194: ExternalProject_Add(fftw 
195:   SOURCE_DIR ${SVN_ROOT}/MYFFTW 
196:   PREFIX ${SVN_ROOT}/MYFFTW/local_build_${FC_PROGNAME} 
197:   CONFIGURE_COMMAND ${SVN_ROOT}/MYFFTW/configure F77=${CMAKE_Fortran_COMPILER} --prefix=${SVN_ROOT}/MYFFTW/local_build_${FC_PROGNAME}/install --disable-doc 
198:   BUILD_COMMAND make 
199:   INSTALL_COMMAND ${MAKE_INSTALL}) 
200:   set_target_properties(fftw PROPERTIES Fortran_MODULE_DIRECTORY "${PREFIX}") 
201: set_module_depends(optimlib fftw) 
202: target_link_libraries(optimlib ${SVN_ROOT}/MYFFTW/local_build_${FC_PROGNAME}/install/lib/libfftw3.a) 
203:  
204: include_directories(libmbpol)190: include_directories(libmbpol)
205: add_subdirectory(libmbpol)191: add_subdirectory(libmbpol)
206: set_module_depends(optimlib mbpollib)192: set_module_depends(optimlib mbpollib)
207: # target_link_libraries(optimlib libmbpol)193: # target_link_libraries(optimlib libmbpol)
208: 194: 
209: # Link CHOLMOD195: # Link CHOLMOD
210: #add_subdirectory(${SVN_ROOT}/SuiteSparse SuiteSparse)196: #add_subdirectory(${SVN_ROOT}/SuiteSparse SuiteSparse)
211: #target_link_libraries(optimlib cholmod)197: #target_link_libraries(optimlib cholmod)
212: #include_directories(${SVN_ROOT}/SuiteSparse/SuiteSparse/CHOLMOD/Include)198: #include_directories(${SVN_ROOT}/SuiteSparse/SuiteSparse/CHOLMOD/Include)
213: #include_directories(${SVN_ROOT}/SuiteSparse/SuiteSparse/SuiteSparse_config)199: #include_directories(${SVN_ROOT}/SuiteSparse/SuiteSparse/SuiteSparse_config)
518: if(WITH_DUPLICATE_TESTING)504: if(WITH_DUPLICATE_TESTING)
519:   add_executable(OPTIM_TEST_DUPLICATES getparams.f505:   add_executable(OPTIM_TEST_DUPLICATES getparams.f
520:                                        ${OPTIM_LIB_SOURCES}506:                                        ${OPTIM_LIB_SOURCES}
521:                                        ${ALL_EXTRA_SOURCES} )507:                                        ${ALL_EXTRA_SOURCES} )
522:   set_module_dir(OPTIM_TEST_DUPLICATES)508:   set_module_dir(OPTIM_TEST_DUPLICATES)
523:   set_module_depends(OPTIM_TEST_DUPLICATES BOWMAN_LIB)509:   set_module_depends(OPTIM_TEST_DUPLICATES BOWMAN_LIB)
524:   set_target_properties(OPTIM_TEST_DUPLICATES PROPERTIES LINKER_LANGUAGE "Fortran")510:   set_target_properties(OPTIM_TEST_DUPLICATES PROPERTIES LINKER_LANGUAGE "Fortran")
525:   set_target_properties(OPTIM_TEST_DUPLICATES PROPERTIES COMPILE_DEFINITIONS "${COMPILE_DEFINITIONS};DUMMY_AMBER12;DUMMY_CUDA")511:   set_target_properties(OPTIM_TEST_DUPLICATES PROPERTIES COMPILE_DEFINITIONS "${COMPILE_DEFINITIONS};DUMMY_AMBER12;DUMMY_CUDA")
526:   target_link_libraries(OPTIM_TEST_DUPLICATES ${MYLAPACK_LIBS}512:   target_link_libraries(OPTIM_TEST_DUPLICATES ${MYLAPACK_LIBS}
527:                                               BOWMAN_LIB513:                                               BOWMAN_LIB
528:                                               mbpollib514:                                               mbpollib)
529:                                               ${SVN_ROOT}/MYFFTW/local_build_${FC_PROGNAME}/install/lib/libfftw3.a) 
530: #                                             cholmod ) << This isn't linked to OPTIM yet515: #                                             cholmod ) << This isn't linked to OPTIM yet
531:   add_dependencies(OPTIM_TEST_DUPLICATES optimlib)516:   add_dependencies(OPTIM_TEST_DUPLICATES optimlib)
532: endif(WITH_DUPLICATE_TESTING)517: endif(WITH_DUPLICATE_TESTING)


r33371/DSOFT.f90 2017-10-04 18:30:07.476176053 +0100 r33370/DSOFT.f90 2017-10-04 18:30:10.792219783 +0100
  1: !    SOFT  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/OPTIM/source/ALIGN/DSOFT.f90' in revision 33370
  2: !    FORTRAN Module for calculating Fast SO(3) Fourier transforms (SOFTs) 
  3: !    Copyright (C) 2017  Matthew Griffiths 
  4: !     
  5: !    This program is free software; you can redistribute it and/or modify 
  6: !    it under the terms of the GNU General Public License as published by 
  7: !    the Free Software Foundation; either version 2 of the License, or 
  8: !    (at your option) any later version. 
  9: !     
 10: !    This program is distributed in the hope that it will be useful, 
 11: !    but WITHOUT ANY WARRANTY; without even the implied warranty of 
 12: !    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 13: !    GNU General Public License for more details. 
 14: !     
 15: !    You should have received a copy of the GNU General Public License along 
 16: !    with this program; if not, write to the Free Software Foundation, Inc., 
 17: !    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 
 18:  
 19: !    This code is a FORTRAN reimplementation of the SOFT C++ library from 
 20: !    http://www.cs.dartmouth.edu/~geelong/soft/ under the GNU GPL licence 
 21:  
 22: !    Citation: 
 23: !    Kostelec, P. J., & Rockmore, D. N. (2008). FFTs on the rotation group.  
 24: !    Journal of Fourier Analysis and Applications, 14(2), 145–179.  
 25: !    http://doi.org/10.1007/s00041-008-9013-5 
 26:  
 27: !    Dependencies: 
 28: !        1. FFTW 
 29:  
 30: MODULE DSOFT 
 31:  
 32: USE FFTW3 
 33: USE PREC, ONLY: INT64, REAL64 
 34:  
 35: IMPLICIT NONE 
 36:  
 37: INTEGER(KIND=INT64), SAVE :: BW 
 38: DOUBLE PRECISION, PARAMETER :: PI = 3.141592653589793D0 
 39: DOUBLE PRECISION, SAVE, ALLOCATABLE :: WEIGHTS(:), WIGNERD(:,:,:,:) 
 40:  
 41: CONTAINS 
 42:  
 43: SUBROUTINE SETBANDWIDTH(BANDWIDTH) 
 44:  
 45: IMPLICIT NONE 
 46: INTEGER(KIND=INT64), INTENT(IN) :: BANDWIDTH 
 47:  
 48: ! Check if bandwidth has already been calculated 
 49: IF (BW.NE.BANDWIDTH) THEN 
 50:     IF (ALLOCATED(WEIGHTS)) THEN 
 51:         DEALLOCATE(WEIGHTS) 
 52:     ENDIF 
 53:     IF (ALLOCATED(WIGNERD)) THEN 
 54:         DEALLOCATE(WIGNERD) 
 55:     ENDIF 
 56:     ALLOCATE(WEIGHTS(2*BANDWIDTH)) 
 57:     ALLOCATE(WIGNERD(2*BANDWIDTH,BANDWIDTH,2*BANDWIDTH-1,2*BANDWIDTH-1)) 
 58:     CALL MAKEWEIGHTS(BANDWIDTH) 
 59:     CALL CALCWIGNERD(BANDWIDTH) 
 60: ENDIF 
 61:  
 62: BW = BANDWIDTH 
 63:  
 64: END SUBROUTINE SETBANDWIDTH 
 65:  
 66: SUBROUTINE MAKEWEIGHTS(BANDWIDTH) 
 67:  
 68: IMPLICIT NONE 
 69: INTEGER(KIND=INT64), INTENT(IN) :: BANDWIDTH 
 70:  
 71: DOUBLE PRECISION FUDGE, SINJ 
 72: INTEGER(KIND=INT64) J, K 
 73:  
 74: FUDGE = PI / 4 / BANDWIDTH 
 75:  
 76: DO J=1, BANDWIDTH*2 
 77:     WEIGHTS(J) = 0 
 78:     SINJ = 2.D0 * SIN((2*J-1)*FUDGE) / BANDWIDTH   
 79:     DO K=1,BANDWIDTH   
 80:     WEIGHTS(J) = WEIGHTS(J) + SINJ * SIN((2*J-1)*(2*K-1)*FUDGE) / (2*K - 1)  
 81:     ENDDO 
 82: ENDDO 
 83:  
 84: END SUBROUTINE MAKEWEIGHTS 
 85:  
 86: SUBROUTINE RECURRTERMS(J,M1,M2,A,B,C) 
 87:  
 88: ! The Wigner little d elements are calculated with a recurrence relation 
 89: ! This subroutine calculates the appropriate coefficients of the recurrent  
 90: ! relation. For more information see: 
 91: ! 
 92: !    Kostelec, P. J., & Rockmore, D. N. (2008). FFTs on the rotation group.  
 93: !    Journal of Fourier Analysis and Applications, 14(2), 145–179.  
 94: !    http://doi.org/10.1007/s00041-008-9013-5 
 95:  
 96: IMPLICIT NONE 
 97:  
 98: INTEGER(KIND=INT64), INTENT(IN) :: J,M1,M2 
 99: DOUBLE PRECISION, INTENT(OUT) :: A, B, C 
100:  
101: DOUBLE PRECISION T1,T2,T3,T4,T5,DJ,DM1,DM2 
102:  
103: DJ = REAL(J,8) 
104: DM1 = REAL(M1,8) 
105: DM2 = REAL(M2,8) 
106:  
107: T1 = ((2.D0*DJ +3.D0)/(2.D0*DJ + 1.D0))**0.5D0 
108: T3 = (DJ+1.D0)*(2.D0*DJ+1.D0) 
109: T5 = (((DJ+1.D0)**2-DM1**2)*((DJ+1.D0)**2-DM2**2))**(-0.5) 
110: B = T1*T3*T5 
111:  
112: IF (J.EQ.0) THEN 
113:     A=0.D0 
114:     C=0.D0 
115: ELSE 
116:     T2 = ( (2.D0*DJ +3.D0)/(2.D0*DJ-1.D0) )**0.5D0 * (DJ+1.D0)/DJ 
117:     T4 = ( (DJ**2-DM1**2)*(DJ**2-DM2**2) )**(0.5) 
118:     A = T2*T4*T5 
119:     C = M1*M2 / (DJ*(DJ+1.D0)) 
120: ENDIF 
121:  
122: !WRITE(*,*) J, T1 
123:  
124: END SUBROUTINE RECURRTERMS 
125:  
126: SUBROUTINE CALCWIGNERD(BANDWIDTH) 
127:  
128: ! 
129: ! Calculates normalised Wigner little-d matrix coefficients for euler angles 
130: ! $\beta_k = \frac{\pi(2k+1)}{4 B}, 0\leq k < 2B$ and B = the bandwidth 
131: ! stores result in WIGNERD(k, l, m1, m2) in the SOFT module. 
132: ! 
133: ! Follows method described in: 
134: ! 
135: !    Kostelec, P. J., & Rockmore, D. N. (2008). FFTs on the rotation group.  
136: !    Journal of Fourier Analysis and Applications, 14(2), 145–179.  
137: !    http://doi.org/10.1007/s00041-008-9013-5 
138:  
139: IMPLICIT NONE 
140:  
141: INTEGER(KIND=INT64), INTENT(IN) :: BANDWIDTH 
142:  
143: DOUBLE PRECISION COSB(2*BANDWIDTH+1), COSB2(2*BANDWIDTH+1), SINB2(2*BANDWIDTH+1) 
144: DOUBLE PRECISION SINCOSB2(2*BANDWIDTH+1), SINDIVCOSB2(2*BANDWIDTH+1) 
145: DOUBLE PRECISION, DIMENSION(0:3*BANDWIDTH-1) :: FACTORIALS 
146: 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,MAXM 
148:  
149: FUDGE = PI / 4 / BANDWIDTH 
150: DO I=1,2*BANDWIDTH 
151:     BETA = FUDGE * (2*I-1) 
152:     COSB(I) = COS(BETA) 
153:     COSB2(I) = COS(BETA/2) 
154:     SINB2(I) = SIN(BETA/2) 
155:     SINCOSB2(I) = SINB2(I)*COSB2(I) 
156:     SINDIVCOSB2(I) = SINB2(I)/COSB2(I) 
157: ENDDO  
158:  
159: FACTORIALS(0) = 1.D0 
160: DO I=1, 3*BANDWIDTH-1 
161:     FACTORIALS(I) = I*FACTORIALS(I-1) 
162: ENDDO 
163:  
164: ! Initialise recurrence 
165: WIGNERD(:,:,:,:) = 0.D0 
166: DO M1=-BANDWIDTH-1,BANDWIDTH-1 
167:     IND1 = MODULO(M1, 2*BANDWIDTH-1) + 1 
168:     DO J=ABS(M1), BANDWIDTH-1 
169:         FACTOR = ((2.D0*J+1.D0)*FACTORIALS(2*J)/FACTORIALS(J+M1)/FACTORIALS(J-M1)/2.D0)**0.5 
170:         IND2 = MODULO(-J, 2*BANDWIDTH-1) + 1 
171:         DO I=1,2*BANDWIDTH 
172:         WIGNERD(I,J+1,J+1,IND1)  = FACTOR * COSB2(I)**(J+M1) * (-SINB2(I))**(J-M1)  
173:         WIGNERD(I,J+1,IND2,IND1) = FACTOR * COSB2(I)**(J-M1) * (SINB2(I))**(J+M1) 
174:         WIGNERD(I,J+1,IND1,J+1)  = FACTOR * COSB2(I)**(J+M1) * (SINB2(I))**(J-M1)  
175:         WIGNERD(I,J+1,IND1,IND2) = FACTOR * COSB2(I)**(J-M1) * (-SINB2(I))**(J+M1) 
176:         ENDDO 
177:     ENDDO 
178: ENDDO 
179:  
180: ! Perform recurrence to calculate Wigner Matrix elements 
181: DO M2=-BANDWIDTH-2,BANDWIDTH-2 
182:     IND2 = MODULO(M2, 2*BANDWIDTH-1) + 1 
183:     DO M1=-BANDWIDTH-2,BANDWIDTH-2 
184:         IND1 = MODULO(M1, 2*BANDWIDTH-1) + 1 
185:         MAXM = MAX(ABS(M1),ABS(M2)) 
186:         DO J=MAXM, BANDWIDTH-2 
187:             CALL RECURRTERMS(J,M1,M2,A,B,C) 
188:             DO I=1,2*BANDWIDTH 
189:                 WIGNERD(I,J+2,IND1,IND2) = B * (COSB(I) - C) * WIGNERD(I,J+1,IND1,IND2) 
190:             ENDDO 
191:             IF (J.GT.0) THEN 
192:                 DO I=1,2*BANDWIDTH 
193:                     WIGNERD(I,J+2,IND1,IND2) = WIGNERD(I,J+2,IND1,IND2) - A*WIGNERD(I,J,IND1,IND2)          
194:                 ENDDO 
195:             ENDIF 
196:         ENDDO 
197:     ENDDO 
198: ENDDO 
199:  
200: END SUBROUTINE CALCWIGNERD 
201:  
202:  
203: SUBROUTINE SOFT(INPUT, OUTPUT, BANDWIDTH) 
204:  
205: ! 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. 
207:  
208: IMPLICIT NONE 
209:  
210: INTEGER(KIND=INT64), INTENT(IN) :: 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) 
213:  
214: ! INCLUDE "fftw3.f90" 
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,MAXM 
217:  
218:  
219: CALL SETBANDWIDTH(BANDWIDTH) 
220:  
221: CALL DFFTW_PLAN_DFT_1D(PLAN, (2*BANDWIDTH), IN1D, OUT1D, FFTW_FORWARD, FFTW_ESTIMATE) 
222:  
223: ! Do FFT on axis 1 
224: DO K1=1,2*BANDWIDTH 
225:     DO K2=1,2*BANDWIDTH 
226:         DO K3=1,2*BANDWIDTH 
227:             IN1D(K3) = CMPLX(INPUT(K3,K2,K1),0.D0, REAL64) 
228:         ENDDO 
229:         CALL DFFTW_EXECUTE_(PLAN, IN1D, OUT1D) 
230:         DO K3=1,2*BANDWIDTH 
231:             TEMP(K3,K2,K1) = OUT1D(K3) 
232:         ENDDO 
233:     ENDDO 
234: ENDDO 
235:  
236: ! Do FFT on axis 3 
237: DO K1=1,2*BANDWIDTH 
238:     DO K2=1,2*BANDWIDTH 
239:         DO K3=1,2*BANDWIDTH 
240:             IN1D(K3) = TEMP(K2,K1,K3) 
241:         ENDDO 
242:         CALL DFFTW_EXECUTE_(PLAN, IN1D, OUT1D) 
243:         DO K3=1,2*BANDWIDTH 
244:             TEMP(K2,K1,K3) = OUT1D(K3)/(2*BANDWIDTH)**2 
245:         ENDDO 
246:     ENDDO 
247: ENDDO 
248:  
249: ! Perform Discrete Wigner Transform 
250: OUTPUT = CMPLX(0.D0,0.D0,REAL64) 
251: DO M2=-BANDWIDTH-1,BANDWIDTH-1 
252:     I2 = MODULO(M2, 2*BANDWIDTH) + 1 
253:     IND2 = MODULO(M2, 2*BANDWIDTH-1) + 1 
254:     DO M1=-BANDWIDTH-1,BANDWIDTH-1 
255:         I1 = MODULO(M1, 2*BANDWIDTH) + 1 
256:         IND1 = MODULO(M1, 2*BANDWIDTH-1) + 1 
257:         MAXM = MAX(ABS(M1),ABS(M2)) 
258:         DO J=MAXM, BANDWIDTH-1 
259:             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) 
261:             ENDDO 
262:         ENDDO 
263:     ENDDO 
264: ENDDO 
265:  
266: CALL DFFTW_DESTROY_PLAN_(PLAN) 
267:  
268: END SUBROUTINE SOFT 
269:  
270: SUBROUTINE ISOFT(INPUT, OUTPUT, BANDWIDTH) 
271:  
272: ! Performs SO3 Fourier Synthesis for a complex input array of Fourier Coefficients 
273: ! Generates a complex output array. 
274:  
275: IMPLICIT NONE 
276:  
277: INTEGER(KIND=INT64), INTENT(IN) :: BANDWIDTH 
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) 
280:  
281: ! INCLUDE "fftw3.f90" 
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,MAXM 
284:  
285: CALL SETBANDWIDTH(BANDWIDTH) 
286:  
287: CALL DFFTW_PLAN_DFT_1D(PLAN, (2*BANDWIDTH), IN1D, OUT1D, FFTW_BACKWARD, FFTW_ESTIMATE) 
288:  
289: ! Discrete inverse Wigner Transform 
290: TEMP = CMPLX(0.D0,0.D0,REAL64) 
291: DO M2=-BANDWIDTH-1,BANDWIDTH-1 
292:     I2 = MODULO(M2, 2*BANDWIDTH) + 1 
293:     IND2 = MODULO(M2, 2*BANDWIDTH-1) + 1 
294:     DO M1=-BANDWIDTH-1,BANDWIDTH-1 
295:         I1 = MODULO(M1, 2*BANDWIDTH) + 1 
296:         IND1 = MODULO(M1, 2*BANDWIDTH-1) + 1 
297:         MAXM = MAX(ABS(M1),ABS(M2)) 
298:         DO K1=1,2*BANDWIDTH 
299:             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) 
301:             ENDDO 
302:         ENDDO 
303:     ENDDO 
304: ENDDO 
305:  
306: ! Inverse Fourier Transform on axis 3 
307: DO K1=1,2*BANDWIDTH 
308:     DO K2=1,2*BANDWIDTH 
309:         DO K3=1,2*BANDWIDTH 
310:             IN1D(K3) = TEMP(K2,K1,K3) 
311:         ENDDO 
312:         CALL DFFTW_EXECUTE_(PLAN, IN1D, OUT1D) 
313:         DO K3=1,2*BANDWIDTH 
314:             TEMP(K2,K1,K3) = OUT1D(K3) 
315:         ENDDO 
316:     ENDDO 
317: ENDDO 
318:  
319: ! Inverse Fourier Transform on axis 1 
320: DO K1=1,2*BANDWIDTH 
321:     DO K2=1,2*BANDWIDTH 
322:         DO K3=1,2*BANDWIDTH 
323:             IN1D(K3) = TEMP(K3,K2,K1) 
324:         ENDDO 
325:         CALL DFFTW_EXECUTE_(PLAN, IN1D, OUT1D) 
326:         DO K3=1,2*BANDWIDTH 
327:             OUTPUT(K3,K2,K1) = OUT1D(K3)!/(2*BANDWIDTH)**2 
328:         ENDDO 
329:     ENDDO 
330: ENDDO 
331:  
332: CALL DFFTW_DESTROY_PLAN_(PLAN) 
333:  
334: END SUBROUTINE ISOFT 
335:  
336: ! TODO Implement version of these algorithms that take advantage of the symmetries 
337: ! imposed by a real input array. 
338: ! TODO refactor code to avoid use of MODULO arithmetic 
339:  
340: END MODULE DSOFT 
341:  
342:  
343:  
344:  
345:  
346:  
347:  
348:  
349:  
350:  
351:  
352:  
353:  
354:  
355:  
356:  
357:  


r33371/fastbulk.f90 2017-10-04 18:30:08.356187672 +0100 r33370/fastbulk.f90 2017-10-04 18:30:11.896234346 +0100
  1: !    FASTOVERLAP  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/OPTIM/source/ALIGN/fastbulk.f90' in revision 33370
  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: !*********************************************************************** 
 19: ! BULKFASTOVERLAP MODULE 
 20: !*********************************************************************** 
 21:  
 22: ! Subroutines: 
 23:  
 24: !    FOM_ALIGN_BULK(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,KERNELWIDTH,NDISPLACEMENTS,DISTANCE,DIST2) 
 25: !        MAIN ALIGNMENT ALGORITHM ROUTINE 
 26: !        if KERNELWIDTH=0 then algorithm automatically determines a suitable KWIDTH 
 27: !        If want to test Octahedral symmetry, OHCELLT in KEY needs to be set to be .TRUE. 
 28: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated 
 29:  
 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 
 32: !        If want to test Octahedral symmetry, OHCELLT in KEY needs to be set to be .TRUE. 
 33: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated 
 34:  
 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 
 37: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated 
 38:  
 39: !    SETWAVEK(NWAVE,WAVEK,BOXLX,BOXLY,BOXLZ) 
 40:  
 41: !    PERIODICFOURIER(NATOMS, NWAVE, NCOEFF, COORDS, WAVEK, FCOEFF) 
 42: !        Calculates Fourier Coefficients of COORDS 
 43:  
 44: !    PERIODICFOURIERPERM(COORDS,NATOMS,NWAVE,NCOEFF,WAVEK,FCOEFF,NPERMGROUP) 
 45: !        Calculates Fourier Coefficients of COORDS using the permutation information 
 46: !        set by KEY 
 47:  
 48: !    CALCFSPACE(NATOMS,COORDSA,COORDSB,NWAVE,WAVEK,KWIDTH,NFSPACE,FSPACE) 
 49: !        Calculates overlap integral array 
 50:  
 51: !    FINDDISPS(NATOMS,COORDSA,COORDSB,NWAVE,WAVEK,KWIDTH,NFSPACE,DISPS,NDISPS,DEBUG) 
 52: !        Calculates maximum overlap displacements 
 53:  
 54: !    CHECKKEYWORDS() 
 55: !        Sanity checks for the keywords 
 56:  
 57: !    ALIGN2(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,TWOD,DISTANCE,DIST2,RIGID,DISPBEST,NDISPS,BESTPERM,DISP) 
 58: !        Uses MEDIANMINPERMDIST to perform alignment 
 59: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated 
 60:  
 61: !    MEDIANMINPERMDIST(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,DISTANCE,DIST2,DISPBEST,DISP) 
 62: !        Performs intial alignment by subtracting median displacements. 
 63:  
 64: !    GETDISTANCE(DIST,NATOMS, COORDSB,COORDSA,PERMLIST,BOX) 
 65: !        Calculates periodic distance between two structures 
 66:  
 67: !    GETDISPLACEMENT(DISP,NATOMS,COORDSB,COORDSA,PERMLIST,BOX) 
 68: !        Calculates smallest displacement between each atom in two structures 
 69:  
 70: !    SUBROUTINE OHTRANSFORMCOEFFS(FCOEFF, FCOEFFDUMMY, NWAVE, NF2, NPERMGROUP, OPNUM) 
 71: !        Applies octahedral transformation (specified by OHOPSMAT) to a 3D 
 72: !        array of Fourier Coefficients of a structure. 
 73:  
 74: !*********************************************************************** 
 75:  
 76: ! EXTERNAL MODULES 
 77: !    KEY (key.f90) 
 78: !        Module used mostly for compatibility with GMIN and OPTIM 
 79: !        and subroutines copied from GMIN 
 80: !    ALIGNUTILS depends on LAPACK 
 81: !        Module for alignment routines, including a reduced version of MINPERMDIST 
 82: !    FASTOVERLAPUTILS (fastutils.f90) 
 83: !        Helper Module Needed for Peak Fitting and FFT routines 
 84:  
 85: !*********************************************************************** 
 86:  
 87: MODULE BULKFASTOVERLAP 
 88:  
 89: USE ALIGNUTILS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP, NATOMS, NSETS, SETS, & 
 90:  & BULK_BOXVEC, OHCELLT, TWOD, SAVECOORDS, NSTORED 
 91: USE FASTOVERLAPUTILS, ONLY : DUMMYA, DUMMYB, XBESTA, XBESTASAVE 
 92: USE PREC, ONLY: INT64, REAL64 
 93:  
 94: IMPLICIT NONE 
 95:  
 96: ! If this is set to a value other than zero, algorithm will use this value 
 97: ! else it will set KWIDTH = 1/3 average interatomic separation. 
 98: DOUBLE PRECISION, SAVE :: KWIDTH=0.D0 
 99: DOUBLE PRECISION, SAVE :: OHOPSMAT(3,3,48) 
100:  
101: DATA OHOPSMAT / & 
102:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
103:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
104:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
105:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
106:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
107:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
108:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
109:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
110:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
111:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
112:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
113:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
114:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
115:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
116:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
117:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
118:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
119:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
120:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
121:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
122:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
123:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
124:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
125:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
126:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
127:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
128:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
129:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
130:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
131:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
132:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
133:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
134:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
135:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
136:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
137:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
138:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
139:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
140:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
141:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
142:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
143:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
144:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
145:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
146:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
147:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
148:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
149:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
150:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
151:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
152:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
153:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
154:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
155:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
156:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
157:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
158:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
159:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
160:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
161:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
162:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
163:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
164:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
165:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
166:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
167:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
168:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
169:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
170:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
171:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
172:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
173:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
174:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
175:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
176:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
177:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
178:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
179:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
180:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
181:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
182:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
183:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
184:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
185:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
186:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
187:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
188:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
189:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
190:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
191:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
192:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
193:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
194:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
195:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
196:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
197:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
198:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
199:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
200:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
201:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
202:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
203:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
204:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
205:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
206:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
207:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
208:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
209:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
210:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
211:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
212:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
213:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
214:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
215:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
216:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
217:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
218:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
219:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
220:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
221:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
222:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
223:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
224:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
225:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
226:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
227:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
228:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
229:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
230:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
231:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
232:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
233:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
234:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
235:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
236:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
237:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
238:  & 0.0D0,  0.0D0,  -1.00000000000D0,   & 
239:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
240:  & 0.0D0,  1.00000000000D0,  0.0D0,   & 
241:  & 1.00000000000D0,  0.0D0,  0.0D0,   & 
242:  & 0.0D0,  0.0D0,  1.00000000000D0,   & 
243:  & 0.0D0,  -1.00000000000D0,  0.0D0,   & 
244:  & -1.00000000000D0,  0.0D0,  0.0D0,   & 
245:  & 0.0D0,  0.0D0,  1.00000000000D0 / 
246:  
247:  
248: CONTAINS 
249:  
250: SUBROUTINE CALCDEFAULTS(NCOORDS,BOXLX,BOXLY,BOXLZ,KERNELWIDTH,NWAVE,NFSPACE) 
251:  
252: USE FASTOVERLAPUTILS, ONLY: FASTLEN 
253:  
254: IMPLICIT NONE 
255: INTEGER, INTENT(IN) :: NCOORDS 
256: DOUBLE PRECISION, INTENT(IN) :: BOXLX,BOXLY,BOXLZ 
257: DOUBLE PRECISION, INTENT(OUT) :: KERNELWIDTH 
258: INTEGER, INTENT(OUT) :: NWAVE,NFSPACE 
259:  
260: DOUBLE PRECISION MAXWAVEK 
261:  
262: NATOMS=NCOORDS 
263: KERNELWIDTH = (BOXLX*BOXLY*BOXLZ/NATOMS)**(1.D0/3.D0) / 3.D0 
264: MAXWAVEK = 1.5 / KERNELWIDTH 
265: NWAVE = CEILING(2*3.14159265359/MIN(BOXLX,BOXLY,BOXLZ)*MAXWAVEK, 4) 
266:  
267:  
268: IF((2*NWAVE+1).LE.200) THEN 
269:     NFSPACE = FASTLEN(4*NWAVE+3) 
270: ELSE 
271:     ! PROBABLY NOT THE BEST WAY TO CALCULATE THIS! 
272:     NFSPACE = 2**CEILING(LOG(4.D0*NWAVE+3.D0)/LOG(2.D0),4) 
273: ENDIF 
274:  
275: END SUBROUTINE CALCDEFAULTS 
276:  
277: SUBROUTINE FOM_ALIGN_BULK(COORDSB,COORDSA,NCOORDS,DEBUG,NBOXLX,NBOXLY,NBOXLZ,KERNELWIDTH,NDISPLACEMENTS,DISTANCE,DIST2) 
278: ! COORDSA becomes the optimal alignment of the optimal permutation of COORDSB 
279:  
280: USE FASTOVERLAPUTILS, ONLY: FASTLEN, SETNATOMS 
281: IMPLICIT NONE 
282:  
283: INTEGER, INTENT(IN) :: NCOORDS, NDISPLACEMENTS 
284: LOGICAL, INTENT(IN) :: DEBUG 
285: DOUBLE PRECISION, INTENT(IN) :: NBOXLX, NBOXLY, NBOXLZ, KERNELWIDTH 
286: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS) 
287: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2 
288:  
289: DOUBLE PRECISION KWIDTH, MAXWAVEK 
290: DOUBLE PRECISION BOXLX, BOXLY, BOXLZ 
291: INTEGER NWAVE, NFSPACE, NDISPS 
292:  
293: NATOMS = NCOORDS 
294: BOXLX=NBOXLX; BOXLY=NBOXLY; BOXLZ=NBOXLZ 
295: CALL CHECKKEYWORDS() 
296: CALL SETNATOMS(NATOMS) 
297:  
298:  
299: ! Set KWIDTH to be 1/3 of the average interatomic separation 
300: IF (KERNELWIDTH.LE.0.D0) THEN 
301:     KWIDTH = (BOXLX*BOXLY*BOXLZ/NATOMS)**(1.D0/3.D0) / 3.D0 
302:     IF (DEBUG) WRITE(*,'(A,G20.10)') 'fastoverlap> kernel distance automatically set to ', KWIDTH 
303: ELSE 
304:     KWIDTH = KERNELWIDTH 
305:     IF (DEBUG) WRITE(*,'(A,G20.10)') 'fastoverlap> kernel distance set to ', KWIDTH 
306: ENDIF 
307:  
308: ! Calculate number of wavevectors that we need to preserve reasonable level of accuracy 
309: MAXWAVEK = 1.5 / KWIDTH 
310: NWAVE = CEILING(2*3.14159265359/MIN(BOXLX,BOXLY,BOXLZ)*MAXWAVEK, 4) 
311: IF (DEBUG) WRITE(*,'(A,G20.10)') 'fastoverlap> max wavevector magnitude set to ', MAXWAVEK 
312:  
313: ! Setting size of Fourier Transform array to be fast 
314: ! This also increases the resolution of the method 
315: IF((2*NWAVE+1).LE.200) THEN 
316:     NFSPACE = FASTLEN(4*NWAVE+3) 
317: ELSE 
318:     ! PROBABLY NOT THE BEST WAY TO CALCULATE THIS! 
319:     NFSPACE = 2**CEILING(LOG(4.D0*NWAVE+3.D0)/LOG(2.D0),4) 
320: ENDIF 
321: IF (DEBUG) WRITE(*,'(A,I4)') 'fastoverlap> overlap array resolution set to ', NFSPACE 
322:  
323:  
324: IF(NDISPLACEMENTS.EQ.0) THEN 
325:     NDISPS = 10 
326: ELSE 
327:     NDISPS = NDISPLACEMENTS 
328: END IF 
329: IF (DEBUG) WRITE(*,'(A,I3)') 'fastoverlap> number of displacements to be tested = ', NDISPS 
330:  
331: !WRITE(*,*) "DEBUG,BOXLX,BOXLY,BOXLZ,KWIDTH,DISTANCE,DIST2,NDISPLACEMENTS,NWAVE,NFSPACE" 
332: !WRITE(*,*) DEBUG,BOXLX,BOXLY,BOXLZ,KWIDTH,DISTANCE,DIST2,NDISPS,NWAVE,NFSPACE 
333: CALL ALIGN1(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,KWIDTH,DISTANCE,DIST2,NDISPS,NWAVE,NFSPACE) 
334:  
335: END SUBROUTINE FOM_ALIGN_BULK 
336:  
337: SUBROUTINE ALIGNGROUP(COORDS1LIST,N1LIST,COORDS2LIST,N2LIST,NCOORDS,DEBUG, & 
338:     & NBOXLX,NBOXLY,NBOXLZ,KWIDTH,NDISPLACEMENTS,NWAVE,NFSPACE,DISTMAT,ALIGNEDCOORDS2,SYM) 
339:  
340: USE FASTOVERLAPUTILS, ONLY: SETNATOMS 
341:  
342: IMPLICIT NONE 
343: INTEGER, INTENT(IN) :: N1LIST, N2LIST, NCOORDS, NDISPLACEMENTS, NFSPACE, NWAVE 
344: LOGICAL, INTENT(IN) :: DEBUG,SYM 
345: DOUBLE PRECISION, INTENT(IN) :: NBOXLX, NBOXLY, NBOXLZ, KWIDTH 
346: DOUBLE PRECISION, INTENT(INOUT) :: COORDS1LIST(3*NCOORDS,N1LIST), COORDS2LIST(3*NCOORDS,N2LIST) 
347: DOUBLE PRECISION, INTENT(OUT) :: DISTMAT(N1LIST,N2LIST), ALIGNEDCOORDS2(3*NCOORDS,N1LIST,N2LIST) 
348:  
349: COMPLEX(KIND=REAL64) FCOEFF1(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP,N1LIST), & 
350:     & FCOEFF2(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP,N2LIST), FCOEFFS(NFSPACE,NFSPACE,NFSPACE) 
351: DOUBLE PRECISION WAVEK(3, 2*NWAVE+1,2*NWAVE+1,2*NWAVE+1), K2(2*NWAVE+1,2*NWAVE+1,2*NWAVE+1), DIST2 
352: DOUBLE PRECISION BOXLX, BOXLY, BOXLZ 
353: INTEGER I,J,K,JX,JY,JZ,NDISPS 
354:  
355: IF (DEBUG) WRITE(*,'(A)') 'fastoverlap> starting group alignment' 
356: IF (DEBUG) WRITE(*,'(A,I5,A,I5)') 'fastoverlap> aligning ', N1LIST, ' structures with ', N2LIST 
357:  
358: SAVECOORDS = .FALSE. !Don't save coordinates when doing group alignment 
359: NATOMS = NCOORDS 
360: BOXLX=NBOXLX; BOXLY=NBOXLY; BOXLZ=NBOXLZ 
361: CALL SETNATOMS(NATOMS) 
362:  
363: CALL SETWAVEK(NWAVE,WAVEK,BOXLX,BOXLY,BOXLZ) 
364: DO JZ=1,2*NWAVE+1 
365:     DO JY=1,2*NWAVE+1 
366:         DO JX=1,2*NWAVE+1 
367:             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) 
368:         ENDDO 
369:     ENDDO 
370: ENDDO 
371:  
372: DO J=1,N1LIST 
373:     CALL PERIODICFOURIERPERM(COORDS1LIST(:,J),NATOMS,NWAVE,NFSPACE,WAVEK,FCOEFF1(:,:,:,:,J),NPERMGROUP) 
374:     DO I=1,NPERMGROUP 
375:         FCOEFF1(:,:,:,I,J) = FCOEFF1(:,:,:,I,J)*K2(:,:,:) 
376:     ENDDO 
377: ENDDO 
378:  
379: IF(.NOT.SYM) THEN 
380:     DO J=1,N2LIST 
381:         CALL PERIODICFOURIERPERM(COORDS2LIST(:,J),NATOMS,NWAVE,NFSPACE,WAVEK,FCOEFF2(:,:,:,:,J),NPERMGROUP) 
382:         DO I=1,NPERMGROUP 
383:             FCOEFF2(:,:,:,I,J) = CONJG(FCOEFF2(:,:,:,I,J))*K2(:,:,:) 
384:         ENDDO 
385:     ENDDO 
386: ELSE 
387:     FCOEFF2 = CONJG(FCOEFF1) 
388: ENDIF 
389:  
390: IF (SYM) THEN 
391:     DO J=1,N2LIST 
392:         IF (DEBUG) WRITE(*,'(A,I3)') 'fastoverlap> aligning structure', J 
393:         DO I=J,N1LIST 
394:             IF (DEBUG) WRITE(*,'(A,I3)') 'fastoverlap> with structure', I 
395:             CALL DOTFOURIERCOEFFS(FCOEFF1(:,:,:,:,I),FCOEFF2(:,:,:,:,J),NWAVE,NFSPACE,FCOEFFS,NPERMGROUP) 
396:             ALIGNEDCOORDS2(:,I,J) = COORDS2LIST(:,J) 
397:             NDISPS = NDISPLACEMENTS 
398:             CALL ALIGNCOEFFS(COORDS1LIST(:,I),ALIGNEDCOORDS2(:,I,J),NATOMS,DEBUG,FCOEFFS,NFSPACE, & 
399:                 & BOXLX,BOXLY,BOXLZ,DISTMAT(I,J),DIST2,NDISPS) 
400:         ENDDO 
401:     ENDDO 
402: ELSE 
403:     DO J=1,N2LIST 
404:         IF (DEBUG) WRITE(*,'(A,I3)') 'fastoverlap> aligning structure', J 
405:         DO I=1,N1LIST 
406:             IF (DEBUG) WRITE(*,'(A,I3)') 'fastoverlap> with structure', I 
407:             CALL DOTFOURIERCOEFFS(FCOEFF1(:,:,:,:,I),FCOEFF2(:,:,:,:,J),NWAVE,NFSPACE,FCOEFFS,NPERMGROUP) 
408:             ALIGNEDCOORDS2(:,I,J) = COORDS2LIST(:,J) 
409:             NDISPS = NDISPLACEMENTS 
410:             CALL ALIGNCOEFFS(COORDS1LIST(:,I),ALIGNEDCOORDS2(:,I,J),NATOMS,DEBUG,FCOEFFS,NFSPACE, & 
411:                 & BOXLX,BOXLY,BOXLZ,DISTMAT(I,J),DIST2,NDISPS) 
412:         ENDDO 
413:     ENDDO 
414: ENDIF 
415:  
416: END SUBROUTINE ALIGNGROUP 
417:  
418: SUBROUTINE ALIGN1(COORDSB,COORDSA,NCOORDS,DEBUG,NBOXLX,NBOXLY,NBOXLZ,KWIDTH,DISTANCE,DIST2,NDISPLACEMENTS,NWAVE,NFSPACE) 
419:  
420: USE ALIGNUTILS, ONLY: OHOPS, PRINTDISTANCES 
421: USE FASTOVERLAPUTILS, ONLY : SETNATOMS 
422:  
423: IMPLICIT NONE 
424:  
425: INTEGER, INTENT(IN) :: NCOORDS, NDISPLACEMENTS, NFSPACE, NWAVE 
426: LOGICAL, INTENT(IN) :: DEBUG 
427: DOUBLE PRECISION, INTENT(IN) :: NBOXLX, NBOXLY, NBOXLZ, KWIDTH 
428: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS) 
429: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2 
430:  
431: DOUBLE PRECISION BOXLX, BOXLY, BOXLZ 
432: DOUBLE PRECISION WAVEK(3, 2*NWAVE+1,2*NWAVE+1,2*NWAVE+1), K2, DISTSAVE 
433: DOUBLE PRECISION SAVEA(3*NCOORDS), SAVEB(3*NCOORDS) 
434: COMPLEX(KIND=REAL64) FCOEFFS(NFSPACE,NFSPACE,NFSPACE), FCOEFFA(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP), & 
435:  & FCOEFFB(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP), FCOEFFDUMMYA(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP) 
436: INTEGER J, JX, JY, JZ, OPNUM, NDISPS, JXL, JYL, JZL, JXH, JYH, JZH, JXI, JYI, JZI 
437:  
438: NSTORED=0 
439: NATOMS=NCOORDS 
440: BOXLX=NBOXLX; BOXLY=NBOXLY; BOXLZ=NBOXLZ 
441: CALL SETNATOMS(NATOMS) 
442:  
443: ! Calculating Fourier Coefficients of COORDSA and COORDSB 
444: CALL SETWAVEK(NWAVE,WAVEK,BOXLX,BOXLY,BOXLZ) 
445: CALL PERIODICFOURIERPERM(COORDSA,NATOMS,NWAVE,NFSPACE,WAVEK,FCOEFFA,NPERMGROUP) 
446: CALL PERIODICFOURIERPERM(COORDSB,NATOMS,NWAVE,NFSPACE,WAVEK,FCOEFFB,NPERMGROUP) 
447:  
448: FCOEFFA = CONJG(FCOEFFA) 
449:  
450: ! Calculating Fourier Coefficients of overlap integral 
451: DO JZ=1,2*NWAVE+1 
452:     DO JY=1,2*NWAVE+1 
453:         DO JX=1,2*NWAVE+1 
454:             K2 = EXP(-0.5D0 * (WAVEK(1,JX,JY,JZ)**2 + WAVEK(2,JX,JY,JZ)**2 + WAVEK(3,JX,JY,JZ)**2)*KWIDTH**2) 
455:             FCOEFFA(JX,JY,JZ,:) = FCOEFFA(JX,JY,JZ,:) * K2 
456:             FCOEFFB(JX,JY,JZ,:) = FCOEFFB(JX,JY,JZ,:) * K2 
457:         ENDDO 
458:     ENDDO 
459: ENDDO 
460:  
461: CALL DOTFOURIERCOEFFS(FCOEFFB,FCOEFFA,NWAVE,NFSPACE,FCOEFFS,NPERMGROUP) 
462:  
463: SAVEB(1:3*NATOMS) = COORDSB(1:3*NATOMS) 
464:  
465: IF (OHCELLT) THEN 
466:     DISTSAVE = HUGE(DISTSAVE) 
467:     DO OPNUM=1,48 
468:         IF (DEBUG) WRITE(*,'(A,I2)') 'fastoverlap> Trying Oh symmetry operation number ',OPNUM 
469:         CALL OHOPS(COORDSA,SAVEA,OPNUM,NATOMS) 
470:         ! Applying octahedral symmetry operation to FCOEFFA 
471:         CALL OHTRANSFORMCOEFFS(FCOEFFA, FCOEFFDUMMYA, NWAVE, NFSPACE-NWAVE-1, NPERMGROUP, OPNUM) 
472:  
473:         CALL DOTFOURIERCOEFFS(FCOEFFB,FCOEFFA,NWAVE,NFSPACE,FCOEFFS,NPERMGROUP) 
474:  
475:         NDISPS = NDISPLACEMENTS 
476:         CALL ALIGNCOEFFS(SAVEB,SAVEA,NATOMS,DEBUG,FCOEFFS,NFSPACE,BOXLX,BOXLY,BOXLZ,DISTANCE,DIST2,NDISPS) 
477:  
478:         IF (DISTANCE.LT.DISTSAVE) THEN 
479:             IF (DEBUG) WRITE(*,'(A,I2,A,G20.10)') & 
480:  & 'fastoverlap> Oh symmetry operation ', OPNUM, ' found better alignment, distance=', distance 
481:             XBESTASAVE(1:3*NATOMS) = SAVEA(1:3*NATOMS) 
482:             DISTSAVE = DISTANCE 
483:         ELSE 
484:             IF (DEBUG) WRITE(*,'(A,G20.10)') & 
485:  & 'fastoverlap> overall best alignment distance=', distsave 
486:         ENDIF 
487:  
488:     ENDDO 
489: ELSE 
490:     IF (DEBUG) WRITE(*,'(A)') 'fastoverlap> not testing Oh symmetry' 
491:  
492:     XBESTASAVE(1:3*NATOMS) = COORDSA(1:3*NATOMS) 
493:     NDISPS = NDISPLACEMENTS 
494:     CALL ALIGNCOEFFS(SAVEB,XBESTASAVE,NATOMS,DEBUG,FCOEFFS,NFSPACE,BOXLX,BOXLY,BOXLZ,DISTSAVE,DIST2,NDISPS) 
495:  
496:     IF (DEBUG) WRITE(*,'(A,G20.10)') & 
497:  & 'fastoverlap> overall best alignment distance=', distsave 
498: ENDIF 
499:  
500: IF(DEBUG.AND.SAVECOORDS) CALL PRINTDISTANCES() 
501:  
502: DISTANCE = DISTSAVE 
503: DIST2 = DISTANCE**2 
504: COORDSA(1:3*NATOMS) = XBESTASAVE(1:3*NATOMS) 
505:  
506: END SUBROUTINE ALIGN1 
507:  
508: SUBROUTINE ALIGNCOEFFS(COORDSB,COORDSA,NCOORDS,DEBUG,FCOEFFS,NFSPACE,LX,LY,LZ,DISTANCE,DIST2,NDISPS) 
509:  
510: USE FASTOVERLAPUTILS, ONLY : FFT3D, FINDPEAKS 
511: USE ALIGNUTILS, ONLY : ITERATIVEALIGN 
512: IMPLICIT NONE 
513:  
514: INTEGER, INTENT(INOUT) :: NDISPS 
515: INTEGER, INTENT(IN) :: NCOORDS, NFSPACE 
516: LOGICAL, INTENT(IN) :: DEBUG 
517: COMPLEX(KIND=REAL64), INTENT(IN) ::  FCOEFFS(NFSPACE,NFSPACE,NFSPACE) 
518: DOUBLE PRECISION, INTENT(IN) :: LX, LY, LZ 
519: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS) 
520: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2 
521:  
522: COMPLEX(KIND=REAL64) FSPACECMPLX(NFSPACE,NFSPACE,NFSPACE) 
523: DOUBLE PRECISION FSPACE(NFSPACE,NFSPACE,NFSPACE), DISPS(NDISPS,3), R(3,3), BESTDIST 
524: DOUBLE PRECISION AMPLITUDES(NDISPS), DISP(3) 
525: DOUBLE PRECISION BOXLX, BOXLY, BOXLZ 
526: INTEGER J, J1, PERMBEST(NCOORDS) 
527:  
528: NATOMS=NCOORDS 
529: BOXLX = LX; BOXLY = LY; BOXLZ = LZ 
530:  
531: CALL FFT3D(NFSPACE,NFSPACE,NFSPACE,FCOEFFS,FSPACECMPLX) 
532: FSPACE = ABS(FSPACECMPLX) 
533:  
534: CALL FINDPEAKS(FSPACE, DISPS, AMPLITUDES, NDISPS, DEBUG) 
535: IF (DEBUG) WRITE(*,'(A,I3,A)') 'fastoverlap> found ', NDISPS, ' candidate displacements' 
536:  
537: DISPS = DISPS - 1.D0 
538: DISPS(:,1) = DISPS(:,1)*BOXLX/NFSPACE 
539: DISPS(:,2) = DISPS(:,2)*BOXLY/NFSPACE 
540: DISPS(:,3) = DISPS(:,3)*BOXLZ/NFSPACE 
541:  
542: BESTDIST = HUGE(BESTDIST) 
543: DUMMYB(1:3*NATOMS) = COORDSB(1:3*NATOMS) 
544: DO J=1,NDISPS 
545:  
546:     IF (TWOD) DISPS(J,3) = 0.D0 
547:     IF (DEBUG.AND.TWOD) WRITE(*,'(A)') 'fastoverlap> twod alignment, setting z displacement to 0' 
548:  
549:     DO J1=1,NATOMS 
550:         DUMMYA(J1*3-2:J1*3) = COORDSA(J1*3-2:J1*3) - DISPS(J,:) 
551:     ENDDO 
552:  
553:     IF (DEBUG) WRITE(*,'(A,I3)') 'fastoverlap> testing displacement', J 
554:     IF (DEBUG) WRITE(*,'(3G20.10)') DISPS(J,:) 
555:  
556:     CALL ITERATIVEALIGN(DUMMYB,DUMMYA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,.TRUE.,DIST2,DISTANCE,R,DISP,PERMBEST) 
557:  
558:     IF (DISTANCE.LT.BESTDIST) THEN 
559:         BESTDIST = DISTANCE 
560:         IF (DEBUG) WRITE(*,'(A,G20.10)') 'fastoverlap> found new best alignment distance=', BESTDIST 
561:         XBESTA(1:3*NATOMS) = DUMMYA(1:3*NATOMS) 
562:     ELSE 
563:         IF (DEBUG) WRITE(*,'(A,G20.10)') 'fastoverlap> best aligment distance found=', BESTDIST 
564:     ENDIF 
565: ENDDO 
566:  
567: IF (DEBUG) WRITE(*,'(A,G20.10)') 'fastoverlap> FINAL best aligment distance found=', BESTDIST 
568:  
569:  
570: COORDSA(1:3*NATOMS) = XBESTA(1:3*NATOMS) 
571: DISTANCE = BESTDIST 
572: DIST2 = BESTDIST**2 
573:  
574: END SUBROUTINE ALIGNCOEFFS 
575:  
576: SUBROUTINE SETWAVEK(NWAVE,WAVEK,NBOXLX,NBOXLY,NBOXLZ) 
577:  
578: ! NWAVE: number of wavevectors >0 in any axis 
579: ! COORDS: coordinate vector 
580: ! WAVEK: wavevectors 
581: ! FCOEFF: fourier coefficients of coordinates 
582:  
583: IMPLICIT NONE 
584: INTEGER, INTENT(IN) :: NWAVE 
585: DOUBLE PRECISION, INTENT(IN) :: NBOXLX,NBOXLY,NBOXLZ 
586: DOUBLE PRECISION, INTENT(OUT) :: WAVEK(3,2*NWAVE+1,2*NWAVE+1,2*NWAVE+1) 
587:  
588: INTEGER IX,IY,IZ 
589: DOUBLE PRECISION :: BOXLX, BOXLY, BOXLZ 
590: DOUBLE PRECISION, PARAMETER :: TWOPI = 6.283185307179586D0 
591: DOUBLE PRECISION KX, KY, KZ 
592:  
593: BOXLX=NBOXLX; BOXLY=NBOXLY; BOXLZ=NBOXLZ 
594: KX = TWOPI / BOXLX 
595: KY = TWOPI / BOXLY 
596: KZ = TWOPI / BOXLZ 
597:  
598: DO IX=1,2*NWAVE+1 
599:     DO IY=1,2*NWAVE+1 
600:         DO IZ=1,2*NWAVE+1 
601:             WAVEK(1,IX,IY,IZ) = KX*(IX-NWAVE-1) 
602:             WAVEK(2,IX,IY,IZ) = KY*(IY-NWAVE-1) 
603:             WAVEK(3,IX,IY,IZ) = KZ*(IZ-NWAVE-1) 
604:         ENDDO 
605:     ENDDO 
606: ENDDO 
607:  
608: END SUBROUTINE SETWAVEK 
609:  
610: SUBROUTINE PERIODICFOURIER(NCOORDS, NWAVE, NCOEFF, COORDS, WAVEK, FCOEFF) 
611: ! Calculates fourier coefficients of a set of coordinates 
612:  
613: ! NATOMS: system size 
614: ! NWAVE: number of wavevectors modes, FCOEFF will have (2*NWAVE+1)^3 elements 
615: ! COORDS: coordinate vector 
616: ! WAVEK: wavevectors 
617: ! FCOEFF: fourier coefficients of coordinates 
618:  
619: IMPLICIT NONE 
620:  
621: INTEGER, INTENT(IN) :: NCOORDS, NWAVE, NCOEFF 
622: DOUBLE PRECISION, INTENT(IN) :: COORDS(3*NCOORDS), WAVEK(3,2*NWAVE+1,2*NWAVE+1,2*NWAVE+1) 
623: !COMPLEX(KIND=REAL64), INTENT(OUT) :: FCOEFF(NCOEFF,NCOEFF,NCOEFF) 
624: COMPLEX(REAL64), INTENT(OUT) :: FCOEFF(NCOEFF,NCOEFF,NCOEFF) 
625:  
626: INTEGER IX,IY,IZ, J, K 
627: DOUBLE PRECISION KR 
628:  
629:  
630: FCOEFF = CMPLX(0.d0,0.d0,REAL64) 
631: DO IX=1,2*NWAVE+1 
632:     DO IY=1,2*NWAVE+1 
633:         DO IZ=1,2*NWAVE+1 
634: !            FCOEFF(IX,IY,IZ) = CMPLX(0.d0,0.d0) 
635:             DO J=1, NCOORDS 
636:                 KR=0.d0 
637:                 DO K=1,3 
638:                     KR = KR + COORDS(3*J-3+K) * WAVEK(K,IX,IY,IZ) 
639:                 ENDDO 
640:                 FCOEFF(IX,IY,IZ) = FCOEFF(IX,IY,IZ) + EXP(CMPLX(0.d0, -KR, REAL64)) 
641:             ENDDO 
642:         ENDDO 
643:     ENDDO 
644: ENDDO 
645:  
646: END SUBROUTINE PERIODICFOURIER 
647:  
648: SUBROUTINE PERIODICFOURIERPERM(COORDS,NCOORDS,NWAVE,NCOEFF,WAVEK,FCOEFF,NPERMGROUPS)!,PERMGROUP,NPERMSIZE,NPERMGROUP) 
649: ! Calculates Fourier coefficients of the different permutations of a structure. 
650:  
651: IMPLICIT NONE 
652:  
653: INTEGER, INTENT(IN) :: NPERMGROUPS 
654: INTEGER, INTENT(IN) :: NCOORDS, NWAVE, NCOEFF 
655: !INTEGER, INTENT(IN) :: PERMGROUP(NCOORDS), NPERMSIZE(NPERMGROUP) 
656: DOUBLE PRECISION, INTENT(IN) :: COORDS(NCOORDS*3),  WAVEK(3,2*NWAVE+1,2*NWAVE+1,2*NWAVE+1) 
657: !DOUBLE PRECISION, INTENT(IN) :: BOXLX,BOXLY,BOXLZ 
658: COMPLEX(KIND=REAL64), INTENT(OUT) :: FCOEFF(NCOEFF,NCOEFF,NCOEFF,NPERMGROUPS) 
659:  
660: COMPLEX(KIND=REAL64) FCOEFFDUMMY(NCOEFF,NCOEFF,NCOEFF) 
661: DOUBLE PRECISION PDUMMY(3*NCOORDS) 
662: INTEGER NDUMMY, J1, J2, PATOMS 
663:  
664: IF (NPERMGROUP.NE.NPERMGROUPS) THEN 
665:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
666:     STOP 
667: ENDIF 
668:  
669: NDUMMY=1 
670:  
671: DO J1=1,NPERMGROUP 
672:     PATOMS=NPERMSIZE(J1) 
673:     DO J2=1,PATOMS 
674:         PDUMMY(3*(J2-1)+1)=COORDS(3*(PERMGROUP(NDUMMY+J2-1)-1)+1) 
675:         PDUMMY(3*(J2-1)+2)=COORDS(3*(PERMGROUP(NDUMMY+J2-1)-1)+2) 
676:         PDUMMY(3*(J2-1)+3)=COORDS(3*(PERMGROUP(NDUMMY+J2-1)-1)+3) 
677:     ENDDO 
678:     CALL PERIODICFOURIER(PATOMS, NWAVE, NCOEFF, PDUMMY, WAVEK, FCOEFFDUMMY) 
679:     FCOEFF(:,:,:,J1) = FCOEFFDUMMY 
680:     NDUMMY=NDUMMY+NPERMSIZE(J1) 
681: ENDDO 
682:  
683: END SUBROUTINE PERIODICFOURIERPERM 
684:  
685: SUBROUTINE DOTFOURIERCOEFFS(FCOEFFB,FCOEFFA,NWAVE,NCOEFF,FCOEFFS,NPERMGROUP) 
686:  
687: IMPLICIT NONE 
688:  
689: INTEGER, INTENT(IN) :: NPERMGROUP, NWAVE, NCOEFF 
690: COMPLEX(KIND=REAL64), INTENT(IN) :: FCOEFFA(NCOEFF,NCOEFF,NCOEFF,NPERMGROUP),FCOEFFB(NCOEFF,NCOEFF,NCOEFF,NPERMGROUP) 
691: COMPLEX(KIND=REAL64), INTENT(OUT) :: FCOEFFS(NCOEFF,NCOEFF,NCOEFF) 
692:  
693: INTEGER J 
694:  
695: FCOEFFS = CMPLX(0.D0,0.D0,REAL64) 
696:  
697: DO J=1,NPERMGROUP 
698:     FCOEFFS = FCOEFFS + FCOEFFA(:,:,:,J)*FCOEFFB(:,:,:,J) 
699: END DO 
700:  
701: END SUBROUTINE DOTFOURIERCOEFFS 
702:  
703: !SUBROUTINE CALCFSPACE(NCOORDS,COORDSA,COORDSB,NWAVE,WAVEK,KWIDTH,NFSPACE,FSPACE)!,NPERMGROUP) 
704: !! 
705: !! Calculate FASTOVERLAP real space array 
706: !! Given two bulk structures calculates the value of the overlap integral as 
707: !! FSPACE(NFSPACE, NFSPACE, NFSPACE). It does this by performing an FFT of the 
708: !! product Fourier coefficients of both structures. 
709: !! 
710: !USE FASTOVERLAPUTILS, ONLY: FFT3D 
711:  
712: !IMPLICIT NONE 
713:  
714: !INTEGER, INTENT(IN) :: NCOORDS, NWAVE, NFSPACE!, NPERMGROUP 
715: !DOUBLE PRECISION, INTENT(IN) :: KWIDTH 
716: !DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS) 
717: !DOUBLE PRECISION, INTENT(IN) :: WAVEK(3, 2*NWAVE+1,2*NWAVE+1,2*NWAVE+1) 
718:  
719: !DOUBLE PRECISION, INTENT(OUT) :: FSPACE(NFSPACE, NFSPACE, NFSPACE) 
720:  
721: !COMPLEX(KIND=REAL64) FCOEFFA(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP), FCOEFFB(NFSPACE,NFSPACE,NFSPACE,NPERMGROUP), COEFF 
722: !COMPLEX(KIND=REAL64) FCOEFF(NFSPACE,NFSPACE,NFSPACE) 
723: !COMPLEX(KIND=REAL64) FSPACECMPLX(NFSPACE,NFSPACE,NFSPACE) 
724:  
725: !INTEGER I, JX, JY, JZ 
726: !DOUBLE PRECISION K2 
727:  
728: !CALL PERIODICFOURIERPERM(COORDSA,NCOORDS,NWAVE,NFSPACE,WAVEK,FCOEFFA,NPERMGROUP)!,PERMGROUP,NPERMSIZE,NPERMGROUP) 
729: !CALL PERIODICFOURIERPERM(COORDSB,NCOORDS,NWAVE,NFSPACE,WAVEK,FCOEFFB,NPERMGROUP)!,PERMGROUP,NPERMSIZE,NPERMGROUP) 
730:  
731: !FCOEFF = DCMPLX(0.D0, 0.D0) 
732: !FCOEFFB = CONJG(FCOEFFB) 
733:  
734: !DO JX=1,2*NWAVE+1 
735: !    DO JY=1,2*NWAVE+1 
736: !        DO JZ=1,2*NWAVE+1 
737: !            COEFF = DCMPLX(0.D0, 0.D0) 
738: !            K2 = -(WAVEK(1,JX,JY,JZ)**2 + WAVEK(2,JX,JY,JZ)**2 + WAVEK(3,JX,JY,JZ)**2)*KWIDTH**2 
739: !            COEFF = SUM(FCOEFFA(JX,JY,JZ,:)*FCOEFFB(JX,JY,JZ,:))*EXP(K2) 
740: !            FCOEFF(JX,JY,JZ) = COEFF 
741: !        ENDDO 
742: !    ENDDO 
743: !ENDDO 
744:  
745: !!Set average overlap to 0 
746: !FCOEFF(NWAVE+1,NWAVE+1,NWAVE+1)=(0.d0,0.d0) 
747:  
748: !CALL FFT3D(NFSPACE,NFSPACE,NFSPACE,FCOEFF,FSPACECMPLX) 
749:  
750: !FSPACE = ABS(FSPACECMPLX) 
751:  
752: !END SUBROUTINE CALCFSPACE 
753:  
754: !SUBROUTINE FINDDISPS(NCOORDS,COORDSA,COORDSB,NWAVE,WAVEK,KWIDTH,NFSPACE,DISPS,NDISPS,DEBUG) 
755: !! 
756: !! Performs FASTOVERLAP alignment for periodic 3D structures 
757: !! 
758: !! Calculates up to NDISPS possible displacements to align coordinates COORDSA and COORDSB 
759: !! Outputs DISPS as fractional coordinates, so DISPS must be multiplied by the lattice vector 
760: !! to obtain the full displacements 
761: !! 
762: !USE FASTOVERLAPUTILS, ONLY: FINDPEAKS 
763: !IMPLICIT NONE 
764: !INTEGER, INTENT(IN) :: NCOORDS, NWAVE, NFSPACE 
765: !INTEGER, INTENT(INOUT) :: NDISPS 
766: !LOGICAL, INTENT(IN) :: DEBUG 
767: !DOUBLE PRECISION, INTENT(IN) :: KWIDTH, COORDSA(3*NCOORDS), COORDSB(3*NCOORDS), WAVEK(3, 2*NWAVE+1,2*NWAVE+1,2*NWAVE+1) 
768: !DOUBLE PRECISION, INTENT(OUT) :: DISPS(NDISPS,3) 
769:  
770: !INTEGER J 
771: !DOUBLE PRECISION FSPACE(NFSPACE, NFSPACE, NFSPACE), AMPLITUDES(NDISPS) 
772:  
773: !CALL CALCFSPACE(NCOORDS,COORDSA,COORDSB,NWAVE,WAVEK,KWIDTH,NFSPACE,FSPACE)!,NPERMGROUP) 
774:  
775: !CALL FINDPEAKS(FSPACE, DISPS, AMPLITUDES, NDISPS, DEBUG) 
776:  
777: !DISPS = DISPS - 1.D0 
778: !DO J=1,NDISPS 
779: !    DISPS(J,:) = DISPS(J,:)/(/NFSPACE,NFSPACE,NFSPACE/) 
780: !ENDDO 
781:  
782: !END SUBROUTINE FINDDISPS 
783:  
784: SUBROUTINE CHECKKEYWORDS() 
785:  
786: USE KEY, ONLY : NFREEZE,GEOMDIFFTOL,ORBITTOL,FREEZE,PULLT, & 
787:     &   EFIELDT,QCIAMBERT, STOCKT,   & 
788:     &   LOCALPERMDIST,LPERMDIST,OHCELLT,QCIPERMCHECK,  & 
789:     &   NOINVERSION,GTHOMSONT,MKTRAPT,RIGIDBODY 
790:  
791: IMPLICIT NONE 
792:  
793: IF((.NOT.ALLOCATED(PERMGROUP)).OR.(.NOT.ALLOCATED(NPERMSIZE))) THEN 
794:     WRITE(*,'(A)') 'ERROR - permutation arrays not set, use PERMDIST keyword' 
795:     STOP 
796: ENDIF 
797:  
798: IF(.NOT. NOINVERSION) THEN 
799:     WRITE(*,'(A)') 'ERROR - bulk fastoverlap requires NOINVERSION keyword to be set' 
800:     WRITE(*,'(A)') 'use keyword OHCELL to use octahedral symmetries' 
801:     STOP 
802: ENDIF 
803:  
804: IF(STOCKT) THEN 
805:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with STOCK keyword' 
806:     STOP 
807: ENDIF 
808:  
809: IF(PULLT) THEN 
810:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with PULL keyword' 
811:     STOP 
812: ENDIF 
813:  
814: IF(EFIELDT) THEN 
815:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with EFIELD keyword' 
816:     STOP 
817: ENDIF 
818:  
819: IF(RIGIDBODY) THEN 
820:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with RIGIDBODY keyword' 
821:     STOP 
822: ENDIF 
823:  
824: IF(QCIPERMCHECK) THEN 
825:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with QCIPERMCHECK keyword' 
826:     STOP 
827: ENDIF 
828:  
829: IF(QCIAMBERT) THEN 
830:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with QCIAMBER keyword' 
831:     STOP 
832: ENDIF 
833:  
834: IF(GTHOMSONT) THEN 
835:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with GTHOMSON keyword' 
836:     STOP 
837: ENDIF 
838:  
839: IF(MKTRAPT) THEN 
840:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with MKTRAP keyword' 
841:     STOP 
842: ENDIF 
843:  
844: IF(FREEZE) THEN 
845:     WRITE(*,'(A)') 'ERROR - fastoverlap unnecessary with FREEZE keyword' 
846:     STOP 
847: ENDIF 
848:  
849: END SUBROUTINE CHECKKEYWORDS 
850:  
851:  
852: SUBROUTINE GETDISPLACEMENT(DISP, NCOORDS, COORDSB, COORDSA, PERMLIST, BOX) 
853:  
854: ! Calculates minimum displacement between atoms in two bulk structures given a 
855: ! permutation specified by PERMLIST 
856: IMPLICIT NONE 
857:  
858: INTEGER, INTENT(IN) :: NCOORDS 
859: DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS), BOX(3) 
860: INTEGER, INTENT(IN) :: PERMLIST(NCOORDS) 
861: DOUBLE PRECISION, INTENT(OUT) :: DISP(3, NCOORDS) 
862:  
863: DOUBLE PRECISION :: D(3) 
864: INTEGER J1, J2, PATOMS, NDUMMY, IND1, IND2 
865:  
866: NDUMMY=0 
867: DO J1=1,NPERMGROUP 
868:     PATOMS=NPERMSIZE(J1) 
869:     DO J2=1,PATOMS 
870:         IND1 = J2+NDUMMY 
871:         IND2 = PERMLIST(J2+NDUMMY) 
872:         D = COORDSB(3*IND1-2:3*IND1) - COORDSA(3*IND2-2:3*IND2) 
873:         D = D - BOX*ANINT(D/BOX) 
874:         DISP(:,IND1) = D 
875:     ENDDO 
876:     NDUMMY = NDUMMY+PATOMS 
877: ENDDO 
878:  
879: END SUBROUTINE GETDISPLACEMENT 
880:  
881: SUBROUTINE OHTRANSFORMCOEFFS(FCOEFF, FCOEFFDUMMY, NWAVE, NF2, NPERMGROUP, OPNUM) 
882: ! Transforms coefficients by the corresponding octahedral transformation 
883: ! NF2 = NCOEFF - NWAVE - 1 
884:  
885: ! Code generated by the following python script: 
886: !Jstr = ['JX','JY','JZ'] 
887: !Js = np.array(['','JX','JY','JZ','-JZ','-JY','-JX']) 
888: !prestring = """        DO J=1,NPERMGROUP 
889: !            DO JZ=-NWAVE,NWAVE 
890: !                DO JY=-NWAVE,NWAVE 
891: !                    DO JX=-NWAVE,NWAVE""" 
892: !poststring = """                    ENDDO 
893: !                ENDDO 
894: !            ENDDO 
895: !        ENDDO""" 
896: !arraystr = "                        FCOEFFDUMMY({0[0]},{0[1]},{0[2]},J) = FCOEFF({1[0]},{1[1]},{1[2]},J)" 
897: ! 
898: !print 'SELECT CASE (OPNUM)' 
899: !for i in xrange(48): 
900: !    J, Iind = ohopsmat[:,:,i].T.nonzero() 
901: !    Jind = (Iind + 1) * ohopsmat[Iind,J,i].astype(int) 
902: !    print '    CASE ({})'.format(i+1) 
903: !    print prestring 
904: !    print arraystr.format(Jstr, Js[Jind]) 
905: !    print poststring 
906: !print 'END SELECT' 
907: ! 
908: IMPLICIT NONE 
909: INTEGER, INTENT(IN) :: NF2, NWAVE, NPERMGROUP, OPNUM 
910: COMPLEX(KIND=REAL64), INTENT(IN) :: FCOEFF(-NWAVE:NF2,-NWAVE:NF2,-NWAVE:NF2,NPERMGROUP) 
911: COMPLEX(KIND=REAL64), INTENT(OUT) :: FCOEFFDUMMY(-NWAVE:NF2,-NWAVE:NF2,-NWAVE:NF2,NPERMGROUP) 
912:  
913: INTEGER JX, JY, JZ, J 
914:  
915: SELECT CASE (OPNUM) 
916:     CASE (1) 
917:         DO J=1,NPERMGROUP 
918:             DO JZ=-NWAVE,NWAVE 
919:                 DO JY=-NWAVE,NWAVE 
920:                     DO JX=-NWAVE,NWAVE 
921:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JX,JY,JZ,J) 
922:                     ENDDO 
923:                 ENDDO 
924:             ENDDO 
925:         ENDDO 
926:     CASE (2) 
927:         DO J=1,NPERMGROUP 
928:             DO JZ=-NWAVE,NWAVE 
929:                 DO JY=-NWAVE,NWAVE 
930:                     DO JX=-NWAVE,NWAVE 
931:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JX,-JY,JZ,J) 
932:                     ENDDO 
933:                 ENDDO 
934:             ENDDO 
935:         ENDDO 
936:     CASE (3) 
937:         DO J=1,NPERMGROUP 
938:             DO JZ=-NWAVE,NWAVE 
939:                 DO JY=-NWAVE,NWAVE 
940:                     DO JX=-NWAVE,NWAVE 
941:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JZ,JX,JY,J) 
942:                     ENDDO 
943:                 ENDDO 
944:             ENDDO 
945:         ENDDO 
946:     CASE (4) 
947:         DO J=1,NPERMGROUP 
948:             DO JZ=-NWAVE,NWAVE 
949:                 DO JY=-NWAVE,NWAVE 
950:                     DO JX=-NWAVE,NWAVE 
951:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JY,JX,JZ,J) 
952:                     ENDDO 
953:                 ENDDO 
954:             ENDDO 
955:         ENDDO 
956:     CASE (5) 
957:         DO J=1,NPERMGROUP 
958:             DO JZ=-NWAVE,NWAVE 
959:                 DO JY=-NWAVE,NWAVE 
960:                     DO JX=-NWAVE,NWAVE 
961:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JX,-JY,-JZ,J) 
962:                     ENDDO 
963:                 ENDDO 
964:             ENDDO 
965:         ENDDO 
966:     CASE (6) 
967:         DO J=1,NPERMGROUP 
968:             DO JZ=-NWAVE,NWAVE 
969:                 DO JY=-NWAVE,NWAVE 
970:                     DO JX=-NWAVE,NWAVE 
971:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JZ,-JX,JY,J) 
972:                     ENDDO 
973:                 ENDDO 
974:             ENDDO 
975:         ENDDO 
976:     CASE (7) 
977:         DO J=1,NPERMGROUP 
978:             DO JZ=-NWAVE,NWAVE 
979:                 DO JY=-NWAVE,NWAVE 
980:                     DO JX=-NWAVE,NWAVE 
981:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JY,-JX,JZ,J) 
982:                     ENDDO 
983:                 ENDDO 
984:             ENDDO 
985:         ENDDO 
986:     CASE (8) 
987:         DO J=1,NPERMGROUP 
988:             DO JZ=-NWAVE,NWAVE 
989:                 DO JY=-NWAVE,NWAVE 
990:                     DO JX=-NWAVE,NWAVE 
991:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JX,JY,-JZ,J) 
992:                     ENDDO 
993:                 ENDDO 
994:             ENDDO 
995:         ENDDO 
996:     CASE (9) 
997:         DO J=1,NPERMGROUP 
998:             DO JZ=-NWAVE,NWAVE 
999:                 DO JY=-NWAVE,NWAVE 
1000:                     DO JX=-NWAVE,NWAVE 
1001:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JZ,-JX,-JY,J) 
1002:                     ENDDO 
1003:                 ENDDO 
1004:             ENDDO 
1005:         ENDDO 
1006:     CASE (10) 
1007:         DO J=1,NPERMGROUP 
1008:             DO JZ=-NWAVE,NWAVE 
1009:                 DO JY=-NWAVE,NWAVE 
1010:                     DO JX=-NWAVE,NWAVE 
1011:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JZ,JX,-JY,J) 
1012:                     ENDDO 
1013:                 ENDDO 
1014:             ENDDO 
1015:         ENDDO 
1016:     CASE (11) 
1017:         DO J=1,NPERMGROUP 
1018:             DO JZ=-NWAVE,NWAVE 
1019:                 DO JY=-NWAVE,NWAVE 
1020:                     DO JX=-NWAVE,NWAVE 
1021:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JY,JZ,JX,J) 
1022:                     ENDDO 
1023:                 ENDDO 
1024:             ENDDO 
1025:         ENDDO 
1026:     CASE (12) 
1027:         DO J=1,NPERMGROUP 
1028:             DO JZ=-NWAVE,NWAVE 
1029:                 DO JY=-NWAVE,NWAVE 
1030:                     DO JX=-NWAVE,NWAVE 
1031:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JY,-JZ,JX,J) 
1032:                     ENDDO 
1033:                 ENDDO 
1034:             ENDDO 
1035:         ENDDO 
1036:     CASE (13) 
1037:         DO J=1,NPERMGROUP 
1038:             DO JZ=-NWAVE,NWAVE 
1039:                 DO JY=-NWAVE,NWAVE 
1040:                     DO JX=-NWAVE,NWAVE 
1041:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JZ,-JY,JX,J) 
1042:                     ENDDO 
1043:                 ENDDO 
1044:             ENDDO 
1045:         ENDDO 
1046:     CASE (14) 
1047:         DO J=1,NPERMGROUP 
1048:             DO JZ=-NWAVE,NWAVE 
1049:                 DO JY=-NWAVE,NWAVE 
1050:                     DO JX=-NWAVE,NWAVE 
1051:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JZ,JY,JX,J) 
1052:                     ENDDO 
1053:                 ENDDO 
1054:             ENDDO 
1055:         ENDDO 
1056:     CASE (15) 
1057:         DO J=1,NPERMGROUP 
1058:             DO JZ=-NWAVE,NWAVE 
1059:                 DO JY=-NWAVE,NWAVE 
1060:                     DO JX=-NWAVE,NWAVE 
1061:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JZ,-JX,-JY,J) 
1062:                     ENDDO 
1063:                 ENDDO 
1064:             ENDDO 
1065:         ENDDO 
1066:     CASE (16) 
1067:         DO J=1,NPERMGROUP 
1068:             DO JZ=-NWAVE,NWAVE 
1069:                 DO JY=-NWAVE,NWAVE 
1070:                     DO JX=-NWAVE,NWAVE 
1071:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JZ,JX,-JY,J) 
1072:                     ENDDO 
1073:                 ENDDO 
1074:             ENDDO 
1075:         ENDDO 
1076:     CASE (17) 
1077:         DO J=1,NPERMGROUP 
1078:             DO JZ=-NWAVE,NWAVE 
1079:                 DO JY=-NWAVE,NWAVE 
1080:                     DO JX=-NWAVE,NWAVE 
1081:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JY,-JZ,-JX,J) 
1082:                     ENDDO 
1083:                 ENDDO 
1084:             ENDDO 
1085:         ENDDO 
1086:     CASE (18) 
1087:         DO J=1,NPERMGROUP 
1088:             DO JZ=-NWAVE,NWAVE 
1089:                 DO JY=-NWAVE,NWAVE 
1090:                     DO JX=-NWAVE,NWAVE 
1091:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JY,JZ,-JX,J) 
1092:                     ENDDO 
1093:                 ENDDO 
1094:             ENDDO 
1095:         ENDDO 
1096:     CASE (19) 
1097:         DO J=1,NPERMGROUP 
1098:             DO JZ=-NWAVE,NWAVE 
1099:                 DO JY=-NWAVE,NWAVE 
1100:                     DO JX=-NWAVE,NWAVE 
1101:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JZ,JY,-JX,J) 
1102:                     ENDDO 
1103:                 ENDDO 
1104:             ENDDO 
1105:         ENDDO 
1106:     CASE (20) 
1107:         DO J=1,NPERMGROUP 
1108:             DO JZ=-NWAVE,NWAVE 
1109:                 DO JY=-NWAVE,NWAVE 
1110:                     DO JX=-NWAVE,NWAVE 
1111:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JZ,-JY,-JX,J) 
1112:                     ENDDO 
1113:                 ENDDO 
1114:             ENDDO 
1115:         ENDDO 
1116:     CASE (21) 
1117:         DO J=1,NPERMGROUP 
1118:             DO JZ=-NWAVE,NWAVE 
1119:                 DO JY=-NWAVE,NWAVE 
1120:                     DO JX=-NWAVE,NWAVE 
1121:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JZ,JX,JY,J) 
1122:                     ENDDO 
1123:                 ENDDO 
1124:             ENDDO 
1125:         ENDDO 
1126:     CASE (22) 
1127:         DO J=1,NPERMGROUP 
1128:             DO JZ=-NWAVE,NWAVE 
1129:                 DO JY=-NWAVE,NWAVE 
1130:                     DO JX=-NWAVE,NWAVE 
1131:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JZ,-JX,JY,J) 
1132:                     ENDDO 
1133:                 ENDDO 
1134:             ENDDO 
1135:         ENDDO 
1136:     CASE (23) 
1137:         DO J=1,NPERMGROUP 
1138:             DO JZ=-NWAVE,NWAVE 
1139:                 DO JY=-NWAVE,NWAVE 
1140:                     DO JX=-NWAVE,NWAVE 
1141:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JX,-JY,-JZ,J) 
1142:                     ENDDO 
1143:                 ENDDO 
1144:             ENDDO 
1145:         ENDDO 
1146:     CASE (24) 
1147:         DO J=1,NPERMGROUP 
1148:             DO JZ=-NWAVE,NWAVE 
1149:                 DO JY=-NWAVE,NWAVE 
1150:                     DO JX=-NWAVE,NWAVE 
1151:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JX,JY,-JZ,J) 
1152:                     ENDDO 
1153:                 ENDDO 
1154:             ENDDO 
1155:         ENDDO 
1156:     CASE (25) 
1157:         DO J=1,NPERMGROUP 
1158:             DO JZ=-NWAVE,NWAVE 
1159:                 DO JY=-NWAVE,NWAVE 
1160:                     DO JX=-NWAVE,NWAVE 
1161:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JX,JZ,-JY,J) 
1162:                     ENDDO 
1163:                 ENDDO 
1164:             ENDDO 
1165:         ENDDO 
1166:     CASE (26) 
1167:         DO J=1,NPERMGROUP 
1168:             DO JZ=-NWAVE,NWAVE 
1169:                 DO JY=-NWAVE,NWAVE 
1170:                     DO JX=-NWAVE,NWAVE 
1171:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JX,-JZ,-JY,J) 
1172:                     ENDDO 
1173:                 ENDDO 
1174:             ENDDO 
1175:         ENDDO 
1176:     CASE (27) 
1177:         DO J=1,NPERMGROUP 
1178:             DO JZ=-NWAVE,NWAVE 
1179:                 DO JY=-NWAVE,NWAVE 
1180:                     DO JX=-NWAVE,NWAVE 
1181:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JX,-JZ,JY,J) 
1182:                     ENDDO 
1183:                 ENDDO 
1184:             ENDDO 
1185:         ENDDO 
1186:     CASE (28) 
1187:         DO J=1,NPERMGROUP 
1188:             DO JZ=-NWAVE,NWAVE 
1189:                 DO JY=-NWAVE,NWAVE 
1190:                     DO JX=-NWAVE,NWAVE 
1191:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JX,JZ,JY,J) 
1192:                     ENDDO 
1193:                 ENDDO 
1194:             ENDDO 
1195:         ENDDO 
1196:     CASE (29) 
1197:         DO J=1,NPERMGROUP 
1198:             DO JZ=-NWAVE,NWAVE 
1199:                 DO JY=-NWAVE,NWAVE 
1200:                     DO JX=-NWAVE,NWAVE 
1201:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JY,-JZ,-JX,J) 
1202:                     ENDDO 
1203:                 ENDDO 
1204:             ENDDO 
1205:         ENDDO 
1206:     CASE (30) 
1207:         DO J=1,NPERMGROUP 
1208:             DO JZ=-NWAVE,NWAVE 
1209:                 DO JY=-NWAVE,NWAVE 
1210:                     DO JX=-NWAVE,NWAVE 
1211:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JY,JZ,-JX,J) 
1212:                     ENDDO 
1213:                 ENDDO 
1214:             ENDDO 
1215:         ENDDO 
1216:     CASE (31) 
1217:         DO J=1,NPERMGROUP 
1218:             DO JZ=-NWAVE,NWAVE 
1219:                 DO JY=-NWAVE,NWAVE 
1220:                     DO JX=-NWAVE,NWAVE 
1221:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JY,JZ,JX,J) 
1222:                     ENDDO 
1223:                 ENDDO 
1224:             ENDDO 
1225:         ENDDO 
1226:     CASE (32) 
1227:         DO J=1,NPERMGROUP 
1228:             DO JZ=-NWAVE,NWAVE 
1229:                 DO JY=-NWAVE,NWAVE 
1230:                     DO JX=-NWAVE,NWAVE 
1231:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JY,-JZ,JX,J) 
1232:                     ENDDO 
1233:                 ENDDO 
1234:             ENDDO 
1235:         ENDDO 
1236:     CASE (33) 
1237:         DO J=1,NPERMGROUP 
1238:             DO JZ=-NWAVE,NWAVE 
1239:                 DO JY=-NWAVE,NWAVE 
1240:                     DO JX=-NWAVE,NWAVE 
1241:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JY,-JX,-JZ,J) 
1242:                     ENDDO 
1243:                 ENDDO 
1244:             ENDDO 
1245:         ENDDO 
1246:     CASE (34) 
1247:         DO J=1,NPERMGROUP 
1248:             DO JZ=-NWAVE,NWAVE 
1249:                 DO JY=-NWAVE,NWAVE 
1250:                     DO JX=-NWAVE,NWAVE 
1251:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JY,JX,-JZ,J) 
1252:                     ENDDO 
1253:                 ENDDO 
1254:             ENDDO 
1255:         ENDDO 
1256:     CASE (35) 
1257:         DO J=1,NPERMGROUP 
1258:             DO JZ=-NWAVE,NWAVE 
1259:                 DO JY=-NWAVE,NWAVE 
1260:                     DO JX=-NWAVE,NWAVE 
1261:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JX,JY,JZ,J) 
1262:                     ENDDO 
1263:                 ENDDO 
1264:             ENDDO 
1265:         ENDDO 
1266:     CASE (36) 
1267:         DO J=1,NPERMGROUP 
1268:             DO JZ=-NWAVE,NWAVE 
1269:                 DO JY=-NWAVE,NWAVE 
1270:                     DO JX=-NWAVE,NWAVE 
1271:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JX,-JY,JZ,J) 
1272:                     ENDDO 
1273:                 ENDDO 
1274:             ENDDO 
1275:         ENDDO 
1276:     CASE (37) 
1277:         DO J=1,NPERMGROUP 
1278:             DO JZ=-NWAVE,NWAVE 
1279:                 DO JY=-NWAVE,NWAVE 
1280:                     DO JX=-NWAVE,NWAVE 
1281:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JY,-JX,-JZ,J) 
1282:                     ENDDO 
1283:                 ENDDO 
1284:             ENDDO 
1285:         ENDDO 
1286:     CASE (38) 
1287:         DO J=1,NPERMGROUP 
1288:             DO JZ=-NWAVE,NWAVE 
1289:                 DO JY=-NWAVE,NWAVE 
1290:                     DO JX=-NWAVE,NWAVE 
1291:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JY,JX,-JZ,J) 
1292:                     ENDDO 
1293:                 ENDDO 
1294:             ENDDO 
1295:         ENDDO 
1296:     CASE (39) 
1297:         DO J=1,NPERMGROUP 
1298:             DO JZ=-NWAVE,NWAVE 
1299:                 DO JY=-NWAVE,NWAVE 
1300:                     DO JX=-NWAVE,NWAVE 
1301:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JZ,JY,-JX,J) 
1302:                     ENDDO 
1303:                 ENDDO 
1304:             ENDDO 
1305:         ENDDO 
1306:     CASE (40) 
1307:         DO J=1,NPERMGROUP 
1308:             DO JZ=-NWAVE,NWAVE 
1309:                 DO JY=-NWAVE,NWAVE 
1310:                     DO JX=-NWAVE,NWAVE 
1311:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JZ,-JY,-JX,J) 
1312:                     ENDDO 
1313:                 ENDDO 
1314:             ENDDO 
1315:         ENDDO 
1316:     CASE (41) 
1317:         DO J=1,NPERMGROUP 
1318:             DO JZ=-NWAVE,NWAVE 
1319:                 DO JY=-NWAVE,NWAVE 
1320:                     DO JX=-NWAVE,NWAVE 
1321:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JZ,-JY,JX,J) 
1322:                     ENDDO 
1323:                 ENDDO 
1324:             ENDDO 
1325:         ENDDO 
1326:     CASE (42) 
1327:         DO J=1,NPERMGROUP 
1328:             DO JZ=-NWAVE,NWAVE 
1329:                 DO JY=-NWAVE,NWAVE 
1330:                     DO JX=-NWAVE,NWAVE 
1331:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JZ,JY,JX,J) 
1332:                     ENDDO 
1333:                 ENDDO 
1334:             ENDDO 
1335:         ENDDO 
1336:     CASE (43) 
1337:         DO J=1,NPERMGROUP 
1338:             DO JZ=-NWAVE,NWAVE 
1339:                 DO JY=-NWAVE,NWAVE 
1340:                     DO JX=-NWAVE,NWAVE 
1341:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JX,-JZ,JY,J) 
1342:                     ENDDO 
1343:                 ENDDO 
1344:             ENDDO 
1345:         ENDDO 
1346:     CASE (44) 
1347:         DO J=1,NPERMGROUP 
1348:             DO JZ=-NWAVE,NWAVE 
1349:                 DO JY=-NWAVE,NWAVE 
1350:                     DO JX=-NWAVE,NWAVE 
1351:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JX,JZ,JY,J) 
1352:                     ENDDO 
1353:                 ENDDO 
1354:             ENDDO 
1355:         ENDDO 
1356:     CASE (45) 
1357:         DO J=1,NPERMGROUP 
1358:             DO JZ=-NWAVE,NWAVE 
1359:                 DO JY=-NWAVE,NWAVE 
1360:                     DO JX=-NWAVE,NWAVE 
1361:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JX,JZ,-JY,J) 
1362:                     ENDDO 
1363:                 ENDDO 
1364:             ENDDO 
1365:         ENDDO 
1366:     CASE (46) 
1367:         DO J=1,NPERMGROUP 
1368:             DO JZ=-NWAVE,NWAVE 
1369:                 DO JY=-NWAVE,NWAVE 
1370:                     DO JX=-NWAVE,NWAVE 
1371:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JX,-JZ,-JY,J) 
1372:                     ENDDO 
1373:                 ENDDO 
1374:             ENDDO 
1375:         ENDDO 
1376:     CASE (47) 
1377:         DO J=1,NPERMGROUP 
1378:             DO JZ=-NWAVE,NWAVE 
1379:                 DO JY=-NWAVE,NWAVE 
1380:                     DO JX=-NWAVE,NWAVE 
1381:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(JY,JX,JZ,J) 
1382:                     ENDDO 
1383:                 ENDDO 
1384:             ENDDO 
1385:         ENDDO 
1386:     CASE (48) 
1387:         DO J=1,NPERMGROUP 
1388:             DO JZ=-NWAVE,NWAVE 
1389:                 DO JY=-NWAVE,NWAVE 
1390:                     DO JX=-NWAVE,NWAVE 
1391:                         FCOEFFDUMMY(JX,JY,JZ,J) = FCOEFF(-JY,-JX,JZ,J) 
1392:                     ENDDO 
1393:                 ENDDO 
1394:             ENDDO 
1395:         ENDDO 
1396: END SELECT 
1397:  
1398: END SUBROUTINE OHTRANSFORMCOEFFS 
1399:  
1400: END MODULE BULKFASTOVERLAP 


r33371/fastclusters.f90 2017-10-04 18:30:08.572190497 +0100 r33370/fastclusters.f90 2017-10-04 18:30:12.112237196 +0100
  1: !    FASTOVERLAP  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/OPTIM/source/ALIGN/fastclusters.f90' in revision 33370
  2: ! 
  3: !    FORTRAN Module for calculating Fast SO(3) Fourier transforms (SOFTs) 
  4: !    Copyright (C) 2017  Matthew Griffiths 
  5: ! 
  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 
  8: !    the Free Software Foundation; either version 2 of the License, or 
  9: !    (at your option) any later version. 
 10: ! 
 11: !    This program is distributed in the hope that it will be useful, 
 12: !    but WITHOUT ANY WARRANTY; without even the implied warranty of 
 13: !    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 14: !    GNU General Public License for more details. 
 15: ! 
 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., 
 18: !    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 
 19:  
 20:  
 21: !    Includes code from https://people.sc.fsu.edu/~jburkardt/f_src/special_functions/special_functions.html 
 22: ! 
 23: !    Reference: 
 24: ! 
 25: !    Shanjie Zhang, Jianming Jin, 
 26: !    Computation of Special Functions, 
 27: !    Wiley, 1996, 
 28: !    ISBN: 0-471-11963-6, 
 29: !    LC: QA351.C45. 
 30:  
 31: !*********************************************************************** 
 32: ! CLUSTERFASTOVERLAP MODULE 
 33: !*********************************************************************** 
 34:  
 35: ! Subroutines: 
 36: ! 
 37: !    FOM_ALIGN_CLUSTERS(COORDSB, COORDSA, NATOMS, DEBUG, L, KWIDTH, DISTANCE, DIST2, RMATBEST, NROTATIONS) 
 38: !        MAIN ALIGNMENT ALGORITHM ROUTINE 
 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. 
 41: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated 
 42: ! 
 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 
 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. 
 47: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated 
 48: ! 
 49: !    ALIGNCOEFFS(COORDSB,COORDSA,NATOMS,IMML,L,DEBUG,DISTANCE,DIST2,RMATBEST,NROTATIONS,ANGLES) 
 50: !        Primary alignment routine, called by ALIGN1 
 51: !        Needs PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM to be set and properly allocated 
 52: ! 
 53: !    HARMONIC0L(L, RJ, SIGMA, R0, RET) 
 54: !        Calculates the Harmonic integral when n=0 
 55: ! 
 56: !    HARMONICNL(N,L,RJ,SIGMA,R0,RET) 
 57: !        Calculates Harmonic integral up to N,L 
 58: !        Note calculation unstable, so SIGMA must be > 10 RJ to get good results 
 59: ! 
 60: !    RYML(COORD, R, YML, L) 
 61: !        Calculates |COORD| and the Spherical Harmonic associated with COORD up to l 
 62: ! 
 63: !    HARMONICCOEFFS(COORDS, NATOMS, CNML, N, L, HWIDTH, KWIDTH) 
 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 
 66: ! 
 67: !    DOTHARMONICCOEFFS(C1NML, C2NML, N, L, IMML) 
 68: !        Calculates the SO(3) Fourier Coefficients of the overlap integral of two 
 69: !        structures with coefficient arrays C1NML and C2NML 
 70: ! 
 71: !    FOURIERCOEFFS(COORDSB, COORDSA, NATOMS, L, KWIDTH, IMML, YMLB, YMLA) 
 72: !        Calculates the SO(3) Fourier Coefficients of the overlap integral of two 
 73: !        structures directly by calculating the coefficients of the NATOMS**2 
 74: !        Gaussian overlap functions. 
 75: ! 
 76: !    CALCOVERLAP(IMML, OVERLAP, L, ILMM) 
 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 
 79: ! 
 80: !    FINDROTATIONS(OVERLAP, L, ANGLES, AMPLITUDES, NROTATIONS, DEBUG) 
 81: !        Finds the maximum overlap Euler angles of an overlap integral array 
 82: ! 
 83: !    EULERM(A,B,G,ROTM) 
 84: !        Calculates rotation matrix, ROTM, corresponding to  Euler angles, a,b,g 
 85: ! 
 86: !    EULERINVM(A,B,G,ROTM) 
 87: !        Calculates transpose/inverse of rotation matrix corresponding to Euler angles, a,b,g 
 88: ! 
 89: !    CHECKKEYWORDS() 
 90: !        Sanity checks for the keywords 
 91:  
 92: !*********************************************************************** 
 93:  
 94: ! EXTERNAL SUBROUTINES 
 95: !    MINPERMDIST (minpermdist.f90) depends on (bulkmindist.f90,minperm.f90,newmindist.f90,orient.f90) 
 96: !    XDNRMP (legendre.f90) 
 97: !        Needed to calculate Legendre polynomials 
 98:  
 99: !*********************************************************************** 
100:  
101: ! EXTERNAL MODULES 
102: !    KEY (key.f90) 
103: !    ALIGNUTILS depends on LAPACK 
104: !        Module for alignment routines, including a reduced version of MINPERMDIST 
105: !    FASTOVERLAPUTILS (fastutils.f90) 
106: !        Helper Module Needed for Peak Fitting and FFT routines 
107: !    DSOFT (DSOFT.f90) 
108: !        Module for performing discrete SO(3) transforms, depends on fftw. 
109:  
110: !*********************************************************************** 
111:  
112: MODULE CLUSTERFASTOVERLAP 
113:  
114: USE ALIGNUTILS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP, NATOMS, BESTPERM, & 
115:  & SAVECOORDS, NSTORED, NOINVERSION 
116: USE FASTOVERLAPUTILS, ONLY : DUMMYA, DUMMYB, XBESTA, XBESTASAVE 
117: USE PREC, ONLY: INT64, REAL64 
118:  
119: LOGICAL, SAVE :: NOINVERSIONSAVE 
120:  
121: DOUBLE PRECISION, PARAMETER :: PI = 3.141592653589793D0 
122:  
123: CONTAINS 
124:  
125: SUBROUTINE FOM_ALIGN_CLUSTERS(COORDSB, COORDSA, NCOORDS, DEBUG, L, KWIDTH, DISTANCE, DIST2, RMATBEST, NROTATIONS) 
126:  
127: !  COORDSA becomes the optimal alignment of the optimal permutation(-inversion) 
128: !  isomer. DISTANCE is the residual square distance for the best alignment with 
129: !  respect to permutation(-inversion)s as well as orientation and centre of mass. 
130: !  COORDSA and COORDSB are both centred on the ORIGIN 
131:  
132: !  KWIDTH is the width of the Gaussian kernels that are centered on each of the 
133: !  atomic coordinates, whose overlap integral is maximised to find the optimal 
134: !  rotations 
135:  
136: !  RMATBEST gives the optimal rotation matrix 
137:  
138: !  L is the maximum angular momentum degree up to which the SO(3) coefficients 
139: !  are calculated number of coefficients that will be calculated = 1/3 (L+1)(2L+1)(2L+3) 
140:  
141: !  Number of Calculations for SO(3) calculations ~ O(1/3 (L+1)(2L+1)(2L+3) * NATOMS**2) 
142:  
143: USE FASTOVERLAPUTILS, ONLY : SETNATOMS 
144: IMPLICIT NONE 
145:  
146: INTEGER, INTENT(IN) :: NCOORDS, L 
147: INTEGER, INTENT(IN) :: NROTATIONS 
148: LOGICAL, INTENT(IN) :: DEBUG 
149: DOUBLE PRECISION, INTENT(INOUT) :: KWIDTH ! Gaussian Kernel width 
150: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS) 
151: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2, RMATBEST(3,3) 
152:  
153: COMPLEX(KIND=REAL64) PIMML(-L:L,-L:L,0:L) 
154: COMPLEX(KIND=REAL64) IMML(-L:L,-L:L,0:L), YMLA(-L:L,0:L,NCOORDS), YMLB(-L:L,0:L,NCOORDS) 
155:  
156: DOUBLE PRECISION SAVEA(3*NCOORDS),SAVEB(3*NCOORDS),COMA(3),COMB(3) 
157: DOUBLE PRECISION ANGLES(NROTATIONS,3), DISTSAVE, RMATSAVE(3,3), WORSTRAD, DIST2SAVE 
158: INTEGER J,J1,J2,M1,M2,IND2,NROT,NDUMMY,INVERT,PATOMS 
159: INTEGER SAVEPERM(NCOORDS), KEEPPERM(NCOORDS) 
160:  
161: NATOMS=NCOORDS 
162:  
163: ! Checking keywords are set properly 
164: CALL CHECKKEYWORDS() 
165: CALL SETNATOMS(NATOMS) 
166:  
167: ! If the kernel width is not specified by the user, we choose a value appropriate to this system (1/3 of the average 
168: ! nearest-neighbour separation in COORDSA) 
169: IF (KWIDTH .LE. 0.0D0) CALL CHOOSE_KWIDTH(NATOMS, COORDSA, COORDSB, KWIDTH, DEBUG) 
170:  
171: ! Centering COORDSA and COORDSB on the origin 
172: COMA = 0.D0 
173: COMB = 0.D0 
174: DO J=1,NATOMS 
175:     COMA = COMA + COORDSA(3*J-2:3*J) 
176:     COMB = COMB + COORDSB(3*J-2:3*J) 
177: ENDDO 
178: COMA = COMA/NATOMS 
179: COMB = COMB/NATOMS 
180: DO J=1,NATOMS 
181:     COORDSA(3*J-2:3*J) = COORDSA(3*J-2:3*J) - COMA 
182:     COORDSB(3*J-2:3*J) = COORDSB(3*J-2:3*J) - COMB 
183: ENDDO 
184:  
185: ! Calculating overlap integral separately for each permutation group 
186: IMML = CMPLX(0.D0,0.D0,REAL64) 
187: NDUMMY=1 
188: DO J1=1,NPERMGROUP 
189:     PATOMS=INT(NPERMSIZE(J1),4) 
190:     DO J2=1,PATOMS 
191:         IND2 = PERMGROUP(NDUMMY+J2-1) 
192:         SAVEA(3*J2-2:3*J2)=COORDSA(3*IND2-2:3*IND2) 
193:         SAVEB(3*J2-2:3*J2)=COORDSB(3*IND2-2:3*IND2) 
194:     ENDDO 
195:     CALL FOURIERCOEFFS(SAVEB,SAVEA,PATOMS,L,KWIDTH,PIMML,YMLB,YMLA) 
196:     DO J=0,L 
197:         DO M2=-J,J 
198:             DO M1=-J,J 
199:             IMML(M1,M2,J) = IMML(M1,M2,J) + PIMML(M1,M2,J) 
200:             ENDDO 
201:         ENDDO 
202:     ENDDO 
203:     NDUMMY=NDUMMY+NPERMSIZE(J1) 
204: ENDDO 
205:  
206: SAVEA(1:3*NATOMS) = COORDSA(1:3*NATOMS) 
207: SAVEB(1:3*NATOMS) = COORDSB(1:3*NATOMS) 
208:  
209: NROT = NROTATIONS 
210: CALL ALIGNCOEFFS(SAVEB,SAVEA,NATOMS,IMML,L,DEBUG,DISTSAVE,DIST2SAVE,RMATSAVE,NROT,ANGLES) 
211:  
212: IF (.NOT.NOINVERSION) THEN 
213:     IF (DEBUG) WRITE(*,'(A)') 'fastoverlap> inverting geometry for comparison with target' 
214:     ! Saving non inverted configuration 
215:     XBESTASAVE(1:3*NATOMS) = SAVEA(1:3*NATOMS) 
216:  
217:     ! Calculating overlap integral for inverted configuration 
218:     NDUMMY=1 
219:     DO J1=1,NPERMGROUP 
220:         PATOMS=INT(NPERMSIZE(J1),4) 
221:         DO J2=1,PATOMS 
222:             IND2 = PERMGROUP(NDUMMY+J2-1) 
223:             SAVEA(3*J2-2:3*J2)=-COORDSA(3*IND2-2:3*IND2) 
224:             SAVEB(3*J2-2:3*J2)=COORDSB(3*IND2-2:3*IND2) 
225:         ENDDO 
226:         CALL FOURIERCOEFFS(SAVEB,SAVEA,PATOMS,L,KWIDTH,PIMML,YMLB,YMLA) 
227:         DO J=0,L 
228:             DO M2=-J,J 
229:                 DO M1=-J,J 
230:                     IMML(M1,M2,J) = IMML(M1,M2,J) + PIMML(M1,M2,J) 
231:                 ENDDO 
232:             ENDDO 
233:         ENDDO 
234:         NDUMMY=NDUMMY+NPERMSIZE(J1) 
235:     ENDDO 
236:     SAVEA(1:3*NATOMS) = -COORDSA(1:3*NATOMS) 
237:     SAVEB(1:3*NATOMS) = COORDSB(1:3*NATOMS) 
238:  
239:     NROT = NROTATIONS 
240:     CALL ALIGNCOEFFS(SAVEB,SAVEA,NATOMS,IMML,L,DEBUG,DISTANCE,DIST2,RMATBEST,NROT,ANGLES) 
241:     IF (DISTANCE.LT.DISTSAVE) THEN 
242:         IF (DEBUG) WRITE(*,'(A,G20.10)') & 
243:     &   'fastoverlap> inversion found better alignment, distance=', distance 
244:         COORDSA(1:3*NATOMS) = SAVEA(1:3*NATOMS) 
245:     ELSE 
246:         COORDSA(1:3*NATOMS) = XBESTASAVE(1:3*NATOMS) 
247:         DISTANCE = DISTSAVE 
248:         DIST2 = DIST2SAVE 
249:         RMATBEST = RMATSAVE 
250:         IF (DEBUG) WRITE(*,'(A,G20.10)') & 
251:     &   'fastoverlap> better alignment with no-inversion, distance=', distance 
252:     ENDIF 
253: ELSE 
254:     IF (DEBUG) WRITE(*,'(A)') 'fastoverlap> not inverting geometry for comparison with target' 
255:     COORDSA(1:3*NATOMS) = SAVEA(1:3*NATOMS) 
256:     DISTANCE = DISTSAVE 
257:     DIST2 = DIST2SAVE 
258:     RMATBEST = RMATSAVE 
259: ENDIF 
260:  
261: IF (DEBUG) THEN 
262:     WRITE(*,'(A,G20.10)') 'fastoverlap> overall best distance=', distance 
263:     WRITE(*,'(A)') 'fastoverlap> overall best rotation matrix:' 
264:     WRITE(*, '(3F20.10)') RMATBEST(1:3,1:3) 
265: ENDIF 
266:  
267: END SUBROUTINE FOM_ALIGN_CLUSTERS 
268:  
269: SUBROUTINE ALIGNHARM(COORDSB, COORDSA, NCOORDS, DEBUG, N, L, HWIDTH, KWIDTH, DISTANCE, DIST2, RMATBEST, NROTATIONS) 
270: !  COORDSA becomes the optimal alignment of the optimal permutation(-inversion) 
271: !  isomer. DISTANCE is the residual square distance for the best alignment with 
272: !  respect to permutation(-inversion)s as well as orientation and centre of mass. 
273: !  COORDSA and COORDSB are both centred on the ORIGIN 
274:  
275: !  RMATBEST gives the optimal rotation matrix 
276:  
277: !  KWIDTH is the width of the Gaussian kernels that are centered on each of the 
278: !  atomic coordinates, whose overlap integral is maximised to find the optimal 
279: !  rotations 
280: !  L is the maximum angular momentum degree up to which the SO(3) coefficients 
281: !  are calculated number of coefficients that will be calculated = 1/3 (L+1)(2L+1)(2L+3) 
282:  
283: !  HWIDTH is the lengthscale of the Quantum Harmonic Oscillator Basis 
284: !  N is the maximum order of the Quantum Harmonic Oscillator basis 
285:  
286: !  Number of Calculations for SO(3) calculations ~ O(1/3 (L+1)(2L+1)(2L+3) * NATOMS**2) 
287: USE FASTOVERLAPUTILS, ONLY : SETNATOMS 
288: IMPLICIT NONE 
289:  
290: INTEGER, INTENT(IN) :: NCOORDS, N, L 
291: INTEGER, INTENT(IN) :: NROTATIONS 
292: LOGICAL, INTENT(IN) :: DEBUG 
293: DOUBLE PRECISION, INTENT(IN) :: HWIDTH, KWIDTH 
294: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS) 
295: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2, RMATBEST(3,3) 
296:  
297: COMPLEX(KIND=REAL64) PIMML(-L:L,-L:L,0:L) 
298: COMPLEX(KIND=REAL64) IMML(-L:L,-L:L,0:L), YMLA(-L:L,0:L,NCOORDS), YMLB(-L:L,0:L,NCOORDS) 
299: COMPLEX(KIND=REAL64) COEFFSA(0:N,-L:L,0:L,NPERMGROUP), COEFFSB(0:N,-L:L,0:L,NPERMGROUP) 
300:  
301: DOUBLE PRECISION SAVEA(3*NCOORDS),SAVEB(3*NCOORDS) 
302: DOUBLE PRECISION ANGLES(NROTATIONS,3), DISTSAVE, RMATSAVE(3,3), WORSTRAD, DIST2SAVE 
303: INTEGER J,J1,J2,M1,M2,IND2,NROT,NDUMMY,INVERT,PATOMS 
304: INTEGER SAVEPERM(NCOORDS), KEEPPERM(NCOORDS) 
305:  
306: NATOMS=NCOORDS 
307: ! Checking keywords are set properly 
308: CALL CHECKKEYWORDS() 
309: CALL SETNATOMS(NATOMS) 
310:  
311: ! Calculating overlap integral separately for each permutation group 
312: IMML = CMPLX(0.D0,0.D0,REAL64) 
313: NDUMMY=1 
314: DO J1=1,NPERMGROUP 
315:     PATOMS=INT(NPERMSIZE(J1),4) 
316:     DO J2=1,PATOMS 
317:         IND2 = PERMGROUP(NDUMMY+J2-1) 
318:         SAVEA(3*J2-2:3*J2)=COORDSA(3*IND2-2:3*IND2) 
319:         SAVEB(3*J2-2:3*J2)=COORDSB(3*IND2-2:3*IND2) 
320:     ENDDO 
321:     CALL HARMONICCOEFFS(SAVEA, PATOMS, COEFFSA(:,:,:,J1), N, L, HWIDTH, KWIDTH) 
322:     CALL HARMONICCOEFFS(SAVEB, PATOMS, COEFFSB(:,:,:,J1), N, L, HWIDTH, KWIDTH) 
323:     CALL DOTHARMONICCOEFFS(COEFFSB(:,:,:,J1), COEFFSA(:,:,:,J1), N, L, PIMML) 
324:     DO J=0,L 
325:         DO M2=-J,J 
326:             DO M1=-J,J 
327:             IMML(M1,M2,J) = IMML(M1,M2,J) + PIMML(M1,M2,J) 
328:             ENDDO 
329:         ENDDO 
330:     ENDDO 
331:     NDUMMY=NDUMMY+NPERMSIZE(J1) 
332: ENDDO 
333:  
334: NROT = NROTATIONS 
335: CALL ALIGNCOEFFS(SAVEB,SAVEA,NATOMS,IMML,L,DEBUG,DISTSAVE,DIST2SAVE,RMATSAVE,NROT,ANGLES) 
336:  
337: IF (.NOT.(NOINVERSION)) THEN 
338:     IF (DEBUG) WRITE(*,'(A)') 'fastoverlap> inverting geometry for comparison with target' 
339:     ! Saving non inverted configuration 
340:     XBESTASAVE(1:3*NATOMS) = SAVEA(1:3*NATOMS) 
341:     KEEPPERM(1:NATOMS) = BESTPERM(1:NATOMS) 
342:     SAVEA = -COORDSA(1:3*NATOMS) 
343:     NROT = NROTATIONS 
344:  
345:     ! Recalculating Fourier Coefficients for inverted COORDSA 
346:     IMML = CMPLX(0.D0,0.D0,REAL64) 
347:     NDUMMY=1 
348:     DO J1=1,NPERMGROUP 
349:         DO J=0,L 
350:             COEFFSA(:,:,J,J1) = COEFFSA(:,:,J,J1) * (-1)**(J) 
351:         ENDDO 
352:         CALL DOTHARMONICCOEFFS(COEFFSB(:,:,:,J1), COEFFSA(:,:,:,J1), N, L, PIMML) 
353:         DO J=0,L 
354:             DO M2=-J,J 
355:                 DO M1=-J,J 
356:                 IMML(M1,M2,J) = IMML(M1,M2,J) + PIMML(M1,M2,J) 
357:                 ENDDO 
358:             ENDDO 
359:         ENDDO 
360:         NDUMMY=NDUMMY+NPERMSIZE(J1) 
361:     ENDDO 
362:     CALL ALIGNCOEFFS(SAVEB,SAVEA,NATOMS,IMML,L,DEBUG,DISTANCE,DIST2,RMATBEST,NROT,ANGLES) 
363:  
364:     IF (DISTANCE.LT.DISTSAVE) THEN 
365:         IF (DEBUG) WRITE(*,'(A,G20.10)') & 
366:     &   'fastoverlap> inversion found better alignment, distance=', distance 
367:         COORDSA(1:3*NATOMS) = SAVEA(1:3*NATOMS) 
368:         RMATBEST = RMATSAVE 
369:     ELSE 
370:         COORDSA(1:3*NATOMS) = XBESTASAVE(1:3*NATOMS) 
371:         DISTANCE = DISTSAVE 
372:         DIST2 = DIST2SAVE 
373:         RMATBEST = RMATSAVE 
374:     ENDIF 
375: ELSE 
376:     IF (DEBUG) WRITE(*,'(A)') 'fastoverlap> not inverting geometry for comparison with target' 
377:     COORDSA(1:3*NATOMS) = SAVEA(1:3*NATOMS) 
378:     DISTANCE = DISTSAVE 
379:     DIST2 = DIST2SAVE 
380:     RMATBEST = RMATSAVE 
381: ENDIF 
382:  
383: IF (DEBUG) THEN 
384:     WRITE(*,'(A,G20.10)') 'fastoverlap> overall best distance=', distance 
385:     WRITE(*,'(A)') 'fastoverlap> overall best rotation matrix:' 
386:     WRITE(*, '(3F20.10)') RMATBEST(1:3,1:3) 
387: ENDIF 
388:  
389: END SUBROUTINE ALIGNHARM 
390:  
391: SUBROUTINE ALIGNCOEFFS(COORDSB,COORDSA,NCOORDS,IMML,L,DEBUG,DISTANCE,DIST2,RMATBEST,NROTATIONS,ANGLES) 
392: ! Aligns two structures, specified by COORDSA and COORDSB, aligns COORDSA so it most 
393: ! closely matches COORDSB. 
394: ! Assumes that COORDSA and COORDSB are both centered on their Centers of Mass 
395: ! Uses precalculated Fourier Coefficients, IMML 
396: ! Uses minpermdist to refine alignment 
397:  
398: ! Low-level routine, better to use ALIGN or ALIGNHARM 
399:  
400: USE ALIGNUTILS, ONLY : ITERATIVEALIGN 
401: USE FASTOVERLAPUTILS, ONLY : SETNATOMS 
402: IMPLICIT NONE 
403:  
404: INTEGER, INTENT(IN) :: NCOORDS, L 
405: INTEGER, INTENT(INOUT) :: NROTATIONS 
406: LOGICAL, INTENT(IN) :: DEBUG 
407: DOUBLE PRECISION, INTENT(INOUT) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS) 
408: DOUBLE PRECISION, INTENT(OUT) :: ANGLES(NROTATIONS,3) 
409: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2, RMATBEST(3,3) 
410: COMPLEX(KIND=REAL64), INTENT(IN) :: IMML(-L:L,-L:L,0:L) 
411:  
412: COMPLEX(KIND=REAL64) ILMM(0:L,0:2*L,0:2*L) 
413: DOUBLE PRECISION OVERLAP(2*L+2,2*L+2,2*L+2) 
414: DOUBLE PRECISION AMPLITUDES(NROTATIONS), BESTDIST, RMATSAVE(3,3), RMAT(3,3), WORSTRAD, DISP(3) 
415: INTEGER J, J1, PERMBEST(NCOORDS) 
416:  
417: NATOMS=NCOORDS 
418: CALL SETNATOMS(NATOMS) 
419:  
420: CALL CALCOVERLAP(IMML, OVERLAP, L, ILMM) 
421: CALL FINDROTATIONS(OVERLAP, L, ANGLES, AMPLITUDES, NROTATIONS, DEBUG) 
422: IF (DEBUG) WRITE(*,'(A,I3,A)') 'fastoverlap> found ', NROTATIONS, ' candidate rotations' 
423:  
424:  
425: BESTDIST = HUGE(BESTDIST) 
426: DUMMYB(:) = COORDSB(:3*NATOMS) 
427:  
428: DO J=1,NROTATIONS 
429:  
430:     CALL EULERM(ANGLES(J,1),ANGLES(J,2),ANGLES(J,3),RMATSAVE) 
431:     DO J1=1,NATOMS 
432:         DUMMYA(J1*3-2:J1*3) = MATMUL(RMATSAVE, COORDSA(J1*3-2:J1*3)) 
433:     ENDDO 
434:  
435:     IF (DEBUG) THEN 
436:         WRITE(*,'(A,I3,A)') 'fastoverlap> testing rotation', J, ' with Euler angles:' 
437:         WRITE(*, '(3F20.10)') ANGLES(J,:) 
438:         WRITE(*,'(A)') 'fastoverlap> testing rotation matrix:' 
439:         WRITE(*, '(3F20.10)') RMATSAVE(1:3,1:3) 
440:     ENDIF 
441:  
442:     ! CALL MINPERMDIST(DUMMYB,DUMMYA,NATOMS,DEBUG,0.D0,0.D0,0.D0,.FALSE.,.FALSE.,DISTANCE,DIST2,.FALSE.,RMAT) 
443:     CALL ITERATIVEALIGN(DUMMYB,DUMMYA,NATOMS,DEBUG,0.D0,0.D0,0.D0,.FALSE.,DIST2,DISTANCE,RMAT,DISP,PERMBEST) 
444:         IF (DISTANCE.LT.BESTDIST) THEN 
445:         BESTDIST = DISTANCE 
446:         XBESTA(1:3*NATOMS) = DUMMYA(1:3*NATOMS) 
447:         RMATBEST = MATMUL(RMAT,RMATSAVE) 
448:  
449:         IF (DEBUG) THEN 
450:             WRITE(*,'(A,G20.10)') 'fastoverlap> new best alignment distance=', BESTDIST 
451:             WRITE(*,'(A)') 'fastoverlap> new best rotation matrix:' 
452:             WRITE(*, '(3F20.10)') RMATBEST(1:3,1:3) 
453:         END IF 
454:  
455:     ELSE IF (DEBUG) THEN 
456:         WRITE(*,'(A,G20.10)') 'fastoverlap> best aligment distance found=', BESTDIST 
457:         WRITE(*,'(A)') 'fastoverlap> best rotation matrix found:' 
458:         WRITE(*, '(3F20.10)') RMATBEST(1:3,1:3) 
459:     ENDIF 
460: ENDDO 
461:  
462:  
463: ! Returning Best Coordinates 
464: COORDSA(1:3*NATOMS) = XBESTA(1:3*NATOMS) 
465:  
466: DISTANCE = BESTDIST 
467: DIST2 = BESTDIST**2 
468:  
469: END SUBROUTINE ALIGNCOEFFS 
470:  
471: SUBROUTINE HARMONIC0L(N, RJ, SIGMA, R0, RET) 
472:  
473: IMPLICIT NONE 
474: INTEGER, INTENT(IN) :: N 
475: DOUBLE PRECISION, INTENT(IN) :: RJ, SIGMA, R0 
476: DOUBLE PRECISION, INTENT(OUT) :: RET(0:N) 
477:  
478: DOUBLE PRECISION R0SIGMA 
479: INTEGER I,J,K 
480:  
481: R0SIGMA = 1.D0/(R0**2+SIGMA**2) 
482: RET(0) = SQRT(2.D0*SQRT(PI)*(R0*R0SIGMA)**3) * SIGMA**3 * EXP(-0.5D0*RJ**2*R0SIGMA)*4*PI 
483:  
484: R0SIGMA = SQRT(2.D0) * R0 * RJ * R0SIGMA 
485: DO I=1,N 
486:     RET(I) = R0SIGMA / SQRT(1.D0+2.D0*I) * RET(I-1) 
487: ENDDO 
488:  
489: END SUBROUTINE HARMONIC0L 
490:  
491: SUBROUTINE HARMONICNL(N,L,RJ,SIGMA,R0,RET) 
492:  
493: ! 
494: ! Calculates the value of the overlap integral up to N and L 
495: ! 
496: ! 4\pi \int_0^{\infty} g_{nl}(r)\exp{\left(-\frac{r^2+{r^p_j}^2}{2\sigma^2}\right)} 
497: ! i_l \left( \frac{r r^p_{j}}{\sigma^2} \right) r^2\; \mathrm{d}r 
498: ! 
499: ! N is the maximum quantum number of the Harmonic basis to calculate up to 
500: ! L is the maximum angular moment number to calculate 
501: ! SIGMA is the width of the Gaussian Kernels 
502: ! R0 is the length scale of the Harmonic Basis 
503: ! RET is the matrix of calculate values of the overlap integral 
504: ! 
505:  
506: IMPLICIT NONE 
507: INTEGER, INTENT(IN) :: N, L 
508: DOUBLE PRECISION, INTENT(IN) :: RJ, SIGMA, R0 
509: DOUBLE PRECISION, INTENT(OUT) :: RET(0:N,0:L) 
510:  
511: DOUBLE PRECISION R0SIGMA, RET2, SQRTI 
512: INTEGER I,J,K 
513:  
514: ! Initiate Recurrence 
515: R0SIGMA = 1.D0/(R0**2+SIGMA**2) 
516: RET(0,0) = SQRT(2.D0*SQRT(PI)*(R0*R0SIGMA)**3) * SIGMA**3 * EXP(-0.5D0*RJ**2*R0SIGMA)*4*PI 
517: R0SIGMA = SQRT(2.D0) * R0 * RJ * R0SIGMA 
518: DO J=1,L 
519:     RET(0,J) = R0SIGMA / SQRT(1.D0+2.D0*J) * RET(0,J-1) 
520: ENDDO 
521:  
522: R0SIGMA = SIGMA**2/RJ/R0 
523: ! When I=1 don't calculate RET(I-2,J) 
524: I = 1 
525: SQRTI = 1.D0 
526: DO J=0,L-2 
527:     RET(I,J) = (SQRT(I+J+0.5D0)*RET(I-1,J) - (2.D0*J+3.D0)*SIGMA**2/RJ/R0 * RET(I-1,J+1) -& 
528:         SQRT(I+J+1.5D0) * RET(I-1,J+2))/SQRTI 
529: ENDDO 
530:  
531: DO I=2,N 
532:     SQRTI = SQRT(REAL(I,8)) 
533:     DO J=0,L-2*I 
534:     RET(I,J) = (SQRT(I+J+0.5D0)*RET(I-1,J) - (2.D0*J+3.D0)*SIGMA**2/RJ/R0 * RET(I-1,J+1) -& 
535:         SQRT(I+J+1.5D0) * RET(I-1,J+2) + SQRT(I-1.D0) * RET(I-2,J+2))/SQRTI 
536:     ENDDO 
537: ENDDO 
538:  
539: END SUBROUTINE HARMONICNL 
540:  
541: SUBROUTINE RYML2(COORD, R, YML, L) 
542:  
543: ! Calculates the Spherical Harmonics associated with coordinate COORD 
544: ! up to L, returns R, the distance COORD is from origin 
545: ! Calculates value of Legendre Polynomial Recursively 
546:  
547: ! UNSTABLE WHEN Z CLOSE TO 0 OR 1 
548:  
549: IMPLICIT NONE 
550:  
551: DOUBLE PRECISION, INTENT(IN) :: COORD(3) 
552: INTEGER, INTENT(IN) :: L 
553: DOUBLE PRECISION, INTENT(OUT) :: R 
554: COMPLEX(KIND=REAL64), INTENT(OUT) :: YML(-L:L,0:L) 
555:  
556: INTEGER J, M, INDM1, INDM0, INDM2 
557: DOUBLE PRECISION THETA, PHI, Z, FACTORIALS(0:2*L), SQRTZ, SQRTMJ 
558: COMPLEX(KIND=REAL64) EXPIM(-L:L) 
559:  
560: R = (COORD(1)**2+COORD(2)**2+COORD(3)**2)**0.5 
561: PHI = ATAN2(COORD(2), COORD(1)) 
562: Z = COORD(3)/R 
563: SQRTZ = SQRT(1.D0-Z**2) 
564:  
565: !Calculating Associate Legendre Function 
566: YML = CMPLX(0.D0,0.D0, REAL64) 
567: YML(0,0) = (4*PI)**(-0.5) 
568:  
569: ! Initialising Recurrence for Associated Legendre Polynomials 
570: ! Calculating normalised Legendre Polynomials for better numerical stability 
571: ! Pnorm^m_l = \sqrt{(l-m)!/(l+m)!} P^m_l 
572: DO J=0, L-1 
573:     YML(J+1,J+1) = - SQRT((2.D0*J+1.D0)/(2.D0*J+2.D0)) * SQRTZ* YML(J,J) 
574:     ! Calculating first recurrence term 
575:     YML(J, J+1) = -SQRT(2.D0*(J+1))*Z/SQRTZ * YML(J+1, J+1) 
576: ENDDO 
577:  
578: ! Recurrence for normalised Associated Legendre Polynomials 
579: DO J=1,L 
580:     DO M=J-1,-J+1,-1 
581:         SQRTMJ = SQRT((J+M)*(J-M+1.D0)) 
582:         YML(M-1, J) = -2*M*Z/SQRTMJ/SQRTZ * YML(M, J) - SQRT((J-M)*(J+M+1.D0))/SQRTMJ * YML(M+1,J) 
583:     ENDDO 
584: ENDDO 
585:  
586: ! Calculating exp(imPHI) component 
587: DO M=-L,L 
588:     EXPIM(M) = EXP(CMPLX(0.D0, M*PHI, REAL64)) 
589: ENDDO 
590:  
591: ! Calculate Spherical Harmonics 
592: DO J=1,L 
593:     DO M=-J,J 
594:         INDM0 = MODULO(M, 2*L+1) 
595:         YML(M,J) = EXPIM(M)*YML(M,J) * SQRT((2.D0*J+1.D0)) 
596:     ENDDO 
597: ENDDO 
598:  
599: END SUBROUTINE RYML2 
600:  
601: SUBROUTINE RYML(COORD, R, YML, L) 
602:  
603: ! Calculates the Spherical Harmonics associated with coordinate COORD 
604: ! up to L, returns R, the distance COORD is from origin 
605: ! Calculates value of Legendre Polynomial Recursively 
606:  
607: IMPLICIT NONE 
608:  
609: DOUBLE PRECISION, INTENT(IN) :: COORD(3) 
610: INTEGER, INTENT(IN) :: L 
611: DOUBLE PRECISION, INTENT(OUT) :: R 
612: COMPLEX(KIND=REAL64), INTENT(OUT) :: YML(-L:L,0:L) 
613:  
614: INTEGER J, M, INDM1, INDM0, INDM2, ISIG 
615: DOUBLE PRECISION THETA, PHI, Z, FACTORIALS(0:2*L), SQRTZ, SQRTMJ, PLM(0:L), IPN(0:L), FACT 
616: COMPLEX(KIND=REAL64) EXPIM(-L:L) 
617:  
618: R = (COORD(1)**2+COORD(2)**2+COORD(3)**2)**0.5 
619: PHI = ATAN2(COORD(2), COORD(1)) 
620: Z = COORD(3)/R 
621:  
622: !Calculating Associate Legendre Function 
623: YML = CMPLX(0.D0,0.D0, REAL64) 
624: YML(0,0) = (4*PI)**(-0.5) 
625:  
626: FACT = (2*PI)**(-0.5) 
627:  
628: DO J=0, L 
629:     ! Calculate Normalised Legendre Polynomial 
630:     CALL XDNRMP(J,0,J,Z,1,PLM(0:J),IPN(0:J),ISIG) 
631:     YML(0:J,J) = PLM(0:J) * FACT 
632:     DO M=1,J 
633:         YML(-M,J) = YML(M,J) 
634:         YML(M,J) = YML(-M,J) * (-1)**M 
635:     ENDDO 
636: ENDDO 
637:  
638: ! Calculating exp(imPHI) component 
639: DO M=-L,L 
640:     EXPIM(M) = EXP(CMPLX(0.D0, M*PHI, REAL64)) 
641: ENDDO 
642:  
643: ! Calculate Spherical Harmonics 
644: DO J=1,L 
645:     DO M=-J,J 
646:         INDM0 = MODULO(M, 2*L+1) 
647:         YML(M,J) = EXPIM(M)*YML(M,J) !* SQRT((2.D0*J+1.D0)) 
648:     ENDDO 
649: ENDDO 
650:  
651: END SUBROUTINE RYML 
652:  
653: SUBROUTINE HARMONICCOEFFS(COORDS, NCOORDS, CNML, N, L, HWIDTH, KWIDTH) 
654:  
655: ! 
656: ! For a set of Gaussian Kernels of width KWIDTH at COORDS, 
657: ! this will calculate the coefficients of the isotropic quantum harmonic basis 
658: ! cnlm with length scale HWIDTH up to N and L. 
659: ! 
660:  
661: IMPLICIT NONE 
662:  
663: INTEGER, INTENT(IN) :: NCOORDS, N, L 
664: DOUBLE PRECISION, INTENT(IN) :: COORDS(3*NCOORDS), HWIDTH, KWIDTH 
665: COMPLEX(KIND=REAL64), INTENT(OUT) :: CNML(0:N,-L:L,0:L) 
666:  
667: COMPLEX(KIND=REAL64) :: YML(-L:L,0:L) 
668: DOUBLE PRECISION HARMCOEFFS(0:2*N+L,0:N,0:L), DNL(0:N,0:L+2*N), RJ 
669: INTEGER I,J,K,SI,M,INDM, S 
670:  
671: CNML = CMPLX(0.D0,0.D0,REAL64) 
672:  
673: DO K=1,NCOORDS 
674:     CALL RYML(COORDS(3*K-2:3*K), RJ, YML, L) 
675:     CALL HARMONICNL(N,L+2*N,RJ,KWIDTH,HWIDTH,DNL) 
676:     DO J=0,L 
677:         DO M=-J,J 
678:             INDM = MODULO(M,2*L+1) 
679:             DO I=0,N 
680:                 CNML(I,M,J) = CNML(I,M,J) + DNL(I,J) * CONJG(YML(M,J)) 
681:             ENDDO 
682:         ENDDO 
683:     ENDDO 
684: ENDDO 
685:  
686: END SUBROUTINE HARMONICCOEFFS 
687:  
688: SUBROUTINE HARMONICCOEFFSPERM(COORDS, NCOORDS, CNML, N, L, HWIDTH, KWIDTH, NPERMGROUPS) 
689:  
690: ! 
691: ! For a set of Gaussian Kernels of width KWIDTH at COORDS, 
692: ! this will calculate the coefficients of the isotropic quantum harmonic basis 
693: ! cnlm with length scale HWIDTH up to N and L. 
694: ! Returns coefficients of the different permutations groups 
695: ! 
696:  
697: IMPLICIT NONE 
698:  
699: INTEGER, INTENT(IN) :: NCOORDS, N, L, NPERMGROUPS 
700: DOUBLE PRECISION, INTENT(IN) :: COORDS(3*NCOORDS), HWIDTH, KWIDTH 
701: COMPLEX(KIND=REAL64), INTENT(OUT) :: CNML(0:N,-L:L,0:L,1:NPERMGROUPS) 
702:  
703: DOUBLE PRECISION DUMMY(3*NCOORDS) 
704: INTEGER J1, J2, IND2, NDUMMY, PATOMS 
705:  
706: IF (NPERMGROUP.NE.NPERMGROUPS) THEN 
707:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
708:     STOP 
709: ENDIF 
710:  
711: ! Calculating overlap integral separately for each permutation group 
712: NDUMMY=1 
713: DO J1=1,NPERMGROUP 
714:     PATOMS=NPERMSIZE(J1) 
715:     DO J2=1,PATOMS 
716:         IND2 = PERMGROUP(NDUMMY+J2-1) 
717:         DUMMY(3*J2-2:3*J2)=COORDS(3*IND2-2:3*IND2) 
718:     ENDDO 
719:     CALL HARMONICCOEFFS(DUMMY, PATOMS, CNML(:,:,:,J1), N, L, HWIDTH, KWIDTH) 
720:     NDUMMY=NDUMMY+PATOMS 
721: ENDDO 
722:  
723: END SUBROUTINE HARMONICCOEFFSPERM 
724:  
725: SUBROUTINE HARMONICCOEFFSMULTI(COORDSLIST,NCOORDS,NLIST,CNMLLIST,N,L,HWIDTH,KWIDTH,NPERMGROUPS) 
726:  
727: IMPLICIT NONE 
728:  
729: INTEGER, INTENT(IN) :: NCOORDS, NLIST, N, L, NPERMGROUPS 
730: DOUBLE PRECISION, INTENT(IN) :: COORDSLIST(3*NCOORDS, NLIST), HWIDTH, KWIDTH 
731: COMPLEX(KIND=REAL64), INTENT(OUT) :: CNMLLIST(0:N,-L:L,0:L,1:NPERMGROUPS, NLIST) 
732:  
733: INTEGER I 
734:  
735: !write(*,*) NCOORDS, NLIST, N, L, NPERMGROUPS 
736: !WRITE(*,*) SHAPE(CNMLLIST), SHAPE(COORDSLIST) 
737:  
738: IF (NPERMGROUP.NE.NPERMGROUPS) THEN 
739:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
740:     STOP 
741: ENDIF 
742:  
743: DO I=1,NLIST 
744:     CALL HARMONICCOEFFSPERM(COORDSLIST(:,I),NCOORDS,CNMLLIST(:,:,:,:,I),N,L,HWIDTH,KWIDTH,NPERMGROUP) 
745: ENDDO 
746:  
747: END SUBROUTINE HARMONICCOEFFSMULTI 
748:  
749: SUBROUTINE DOTHARMONICCOEFFS(C1NML, C2NML, N, L, IMML) 
750:  
751: IMPLICIT NONE 
752:  
753: INTEGER, INTENT(IN) :: N, L 
754: COMPLEX(KIND=REAL64), INTENT(IN) :: C1NML(0:N,-L:L,0:L), C2NML(0:N,-L:L,0:L) 
755: COMPLEX(KIND=REAL64), INTENT(OUT) :: IMML(-L:L,-L:L,0:L) 
756:  
757: INTEGER I, J, M1, M2, INDM1, INDM2 
758:  
759: IMML = CMPLX(0.D0,0.D0,REAL64) 
760:  
761: DO J=0,L 
762:     DO M2=-J,J 
763:         DO M1=-J,J 
764:             DO I=0,N 
765:                 IMML(M1,M2,J) = IMML(M1,M2,J) + CONJG(C1NML(I,M1,J))*C2NML(I,M2,J) 
766:             ENDDO 
767:         ENDDO 
768:     ENDDO 
769: ENDDO 
770:  
771: END SUBROUTINE DOTHARMONICCOEFFS 
772:  
773: SUBROUTINE DOTHARMONICCOEFFSPERM(C1NML, C2NML, N, L, IMML, NPERMGROUPS) 
774:  
775: IMPLICIT NONE 
776:  
777: INTEGER, INTENT(IN) :: N, L, NPERMGROUPS 
778: COMPLEX(KIND=REAL64), INTENT(IN) :: C1NML(0:N,-L:L,0:L,NPERMGROUPS), C2NML(0:N,-L:L,0:L,NPERMGROUPS) 
779: COMPLEX(KIND=REAL64), INTENT(OUT) :: IMML(-L:L,-L:L,0:L) 
780:  
781: INTEGER I, J, M1, M2, K, INDM1, INDM2 
782:  
783: IF (NPERMGROUP.NE.NPERMGROUPS) THEN 
784:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
785:     STOP 
786: ENDIF 
787: IMML = CMPLX(0.D0,0.D0,REAL64) 
788:  
789: DO K=1,NPERMGROUP 
790:     DO J=0,L 
791:         DO M2=-J,J 
792:             DO M1=-J,J 
793:                 DO I=0,N 
794:                     IMML(M1,M2,J) = IMML(M1,M2,J) + CONJG(C1NML(I,M1,J,K))*C2NML(I,M2,J,K) 
795:                 ENDDO 
796:             ENDDO 
797:         ENDDO 
798:     ENDDO 
799: ENDDO 
800:  
801: END SUBROUTINE DOTHARMONICCOEFFSPERM 
802:  
803: SUBROUTINE CALCSIMILARITY(C1NML, C2NML, N, L, NPERMGROUPS, NORM, MAXOVER) 
804:  
805: IMPLICIT NONE 
806:  
807: INTEGER, INTENT(IN) :: N, L, NPERMGROUPS 
808: COMPLEX(KIND=REAL64), INTENT(IN) :: C1NML(0:N,-L:L,0:L,NPERMGROUPS), C2NML(0:N,-L:L,0:L,NPERMGROUPS) 
809: DOUBLE PRECISION, INTENT(OUT) :: NORM, MAXOVER 
810:  
811: COMPLEX(KIND=REAL64) IMML(-L:L,-L:L,0:L), ILMM(0:L,0:2*L,0:2*L) 
812: DOUBLE PRECISION OVERLAP(2*L+2,2*L+2,2*L+2) 
813:  
814: INTEGER J,M1,M2 
815:  
816: IF (NPERMGROUP.NE.NPERMGROUPS) THEN 
817:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
818:     STOP 
819: ENDIF 
820:  
821: CALL DOTHARMONICCOEFFSPERM(C1NML, C2NML, N, L, IMML, NPERMGROUP) 
822:  
823: ! Calculated average overlap 
824: DO J=0,L 
825:     DO M2=-J,J 
826:         DO M1=-J,J 
827:             NORM = NORM + REAL(IMML(M1,M2,J),8)**2 + AIMAG(IMML(M1,M2,J))**2 
828:         ENDDO 
829:     ENDDO 
830: ENDDO 
831:  
832: ! Calculate max overlap 
833: CALL CALCOVERLAP(IMML, OVERLAP, L, ILMM) 
834: MAXOVER = MAXVAL(OVERLAP) 
835:  
836: END SUBROUTINE CALCSIMILARITY 
837:  
838: SUBROUTINE CALCSIMILARITIES(C1NMLLIST,N1LIST,C2NMLLIST,N2LIST,N,L,NPERMGROUPS,NORMS,MAXOVERS,SYM) 
839:  
840: IMPLICIT NONE 
841: INTEGER, INTENT(IN) :: N1LIST, N2LIST, N, L, NPERMGROUPS 
842: COMPLEX(KIND=REAL64), INTENT(IN) :: C1NMLLIST(0:N,-L:L,0:L,NPERMGROUPS,N1LIST), & 
843:     & C2NMLLIST(0:N,-L:L,0:L,NPERMGROUPS,N2LIST) 
844: LOGICAL, INTENT(IN) :: SYM 
845: DOUBLE PRECISION, INTENT(OUT) :: NORMS(N1LIST,N2LIST), MAXOVERS(N1LIST,N2LIST) 
846:  
847: INTEGER I1, I2 
848:  
849: IF (NPERMGROUP.NE.NPERMGROUPS) THEN 
850:     WRITE(*,'(A)') 'ERROR - number of permutation arrays inconsistent, stopping' 
851:     STOP 
852: ENDIF 
853:  
854: IF (SYM) THEN 
855:     ! if C1NMLLIST == C2NMLLIST then only need to calculate half the values 
856:     DO I1=1,N1LIST 
857:         DO I2=I1,N1LIST 
858:             CALL CALCSIMILARITY(C1NMLLIST(:,:,:,:,I1), C2NMLLIST(:,:,:,:,I2), N, L, NPERMGROUP, & 
859:                 & NORMS(I1,I2), MAXOVERS(I1,I2)) 
860:             NORMS(I2,I1) = NORMS(I1,I2) 
861:             MAXOVERS(I2,I1) = MAXOVERS(I1,I2) 
862:         ENDDO 
863:     ENDDO 
864: ELSE 
865:     ! Calculate all values 
866:     DO I1=1,N1LIST 
867:         DO I2=1,N1LIST 
868:             CALL CALCSIMILARITY(C1NMLLIST(:,:,:,:,I1), C2NMLLIST(:,:,:,:,I2), N, L, NPERMGROUP, & 
869:                 & NORMS(I1,I2), MAXOVERS(I1,I2)) 
870:         ENDDO 
871:     ENDDO 
872: ENDIF 
873:  
874: END SUBROUTINE CALCSIMILARITIES 
875:  
876: SUBROUTINE CALCOVERLAPMATRICES(COORDSLIST,NCOORDS,NLIST,N,L,HWIDTH,KWIDTH,NORMS,MAXOVERS) 
877:  
878: IMPLICIT NONE 
879:  
880: INTEGER, INTENT(IN) :: NCOORDS, NLIST, N, L 
881: DOUBLE PRECISION, INTENT(IN) :: COORDSLIST(3*NCOORDS, NLIST), HWIDTH, KWIDTH 
882: DOUBLE PRECISION, INTENT(OUT) :: NORMS(NLIST,NLIST), MAXOVERS(NLIST,NLIST) 
883:  
884: COMPLEX(KIND=REAL64) CNMLLIST(0:N,-L:L,0:L,1:NPERMGROUP, NLIST) 
885:  
886: CALL HARMONICCOEFFSMULTI(COORDSLIST,NCOORDS,NLIST,CNMLLIST,N,L,HWIDTH,KWIDTH,NPERMGROUP) 
887: CALL CALCSIMILARITIES(CNMLLIST,NLIST,CNMLLIST,NLIST,N,L,NPERMGROUP,NORMS,MAXOVERS,.TRUE.) 
888:  
889: END SUBROUTINE CALCOVERLAPMATRICES 
890:  
891: SUBROUTINE FOURIERCOEFFS(COORDSB, COORDSA, NCOORDS, L, KWIDTH, IMML, YMLB, YMLA) 
892: ! 
893: ! Calculates S03 Coefficients of the overlap integral of two structures 
894: ! does this calculation by direct calculation of the overlap between every pair 
895: ! of atoms, slower than the Harmonic basis, but slightly more accurate. 
896: ! 
897:  
898: IMPLICIT NONE 
899: INTEGER, INTENT(IN) :: NCOORDS, L 
900: DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS), KWIDTH 
901: COMPLEX(KIND=REAL64), INTENT(OUT) :: IMML(-L:L,-L:L,0:L) 
902:  
903: COMPLEX(KIND=REAL64), INTENT(OUT) ::  YMLA(-L:L,0:L,NCOORDS), YMLB(-L:L,0:L,NCOORDS) 
904: DOUBLE PRECISION RA(NCOORDS), RB(NCOORDS), IL(0:L), R1R2, EXPRA(NCOORDS), EXPRB(NCOORDS), FACT, TMP 
905:  
906: INTEGER IA,IB,I,J,K,M1,M2,INDM1,INDM2 
907:  
908: YMLA = CMPLX(0.D0,0.D0,REAL64) 
909: YMLB = CMPLX(0.D0,0.D0,REAL64) 
910: ! Precalculate some values 
911: DO I=1,NCOORDS 
912:     CALL RYML(COORDSA(3*I-2:3*I), RA(I), YMLA(:,:,I), L) 
913:     CALL RYML(COORDSB(3*I-2:3*I), RB(I), YMLB(:,:,I), L) 
914:     EXPRA(I) = EXP(-0.25D0 * RA(I)**2 / KWIDTH**2) 
915:     EXPRB(I) = EXP(-0.25D0 * RB(I)**2 / KWIDTH**2) 
916: ENDDO 
917:  
918: FACT = 4.D0 * PI**2.5 * KWIDTH**3 
919:  
920: IMML = CMPLX(0.D0,0.D0,REAL64) 
921: DO IA=1,NCOORDS 
922:     DO IB=1,NCOORDS 
923:         ! Don't calculate cross terms for points separated by 4 kwidths to speed up calculation 
924:         IF (ABS(RA(IA)-RB(IB)).LT.(4*KWIDTH)) THEN 
925:             R1R2 = 0.5D0 * RA(IA)*RB(IB)/KWIDTH**2 
926:             CALL SPHI(L, R1R2, K, IL) 
927:             TMP = FACT*EXPRA(IA)*EXPRB(IB)!*SQRT(PI/2/R1R2) 
928:             DO J=0,L 
929:                 DO M2=-L,L 
930:                     DO M1=-L,L 
931:                         IMML(M1,M2,J) = IMML(M1,M2,J) + IL(J)*YMLB(M1,J,IB)*CONJG(YMLA(M2,J,IA))*TMP 
932:                     ENDDO 
933:                 ENDDO 
934:             ENDDO 
935:         END IF 
936:     ENDDO 
937: ENDDO 
938:  
939: END SUBROUTINE FOURIERCOEFFS 
940:  
941: SUBROUTINE CALCOVERLAP(IMML, OVERLAP, L, ILMM) 
942: ! Converts an array of SO(3) Fourier Coefficients to a discrete 
943: ! overlap array using a fast discrete SO(3) Fourier Transform (DSOFT) 
944:  
945: USE DSOFT, ONLY : ISOFT 
946:  
947: IMPLICIT NONE 
948: INTEGER, INTENT(IN) :: L 
949: COMPLEX(KIND=REAL64), INTENT(IN) :: IMML(-L:L,-L:L,0:L) 
950: DOUBLE PRECISION, INTENT(OUT) :: OVERLAP(2*L+2,2*L+2,2*L+2) 
951:  
952: COMPLEX(KIND=REAL64), INTENT(OUT) :: ILMM(0:L,0:2*L,0:2*L) 
953: COMPLEX(KIND=REAL64) FROT(2*L+2,2*L+2,2*L+2) 
954: INTEGER I,J,M1,M2, NJ 
955: INTEGER(KIND=INT64) BW 
956:  
957: ! Convert array into format usable by DSOFT: 
958: BW = INT(L+1,8) 
959: NJ = 2*L + 1 
960:  
961: ILMM = CMPLX(0.D0, 0.D0, REAL64) 
962: DO J=0,L 
963:     ILMM(J,0,0) = IMML(0,0,J) 
964:     DO M2=1,J 
965:         ILMM(J,0,M2) = IMML(0,M2,J) 
966:         ILMM(J,0,NJ-M2) = IMML(0,-M2,J) 
967:         ILMM(J,M2,0) = IMML(M2,0,J) 
968:         ILMM(J,NJ-M2,0) = IMML(-M2,0,J) 
969:         DO M1=1,J 
970:             ILMM(J,M1,M2) = IMML(M1,M2,J) 
971:             ILMM(J,NJ-M1,M2) = IMML(-M1,M2,J) 
972:             ILMM(J,M1,NJ-M2) = IMML(M1,-M2,J) 
973:             ILMM(J,NJ-M1,NJ-M2) = IMML(-M1,-M2,J) 
974:         ENDDO 
975:     ENDDO 
976: ENDDO 
977:  
978: ! Perform inverse discrete SO(3) Fourier Transform (DSOFT) 
979: CALL ISOFT(ILMM, FROT, BW) 
980: ! Output is complex so must be converted back to real 
981: OVERLAP = REAL(FROT, 8) 
982:  
983: END SUBROUTINE CALCOVERLAP 
984:  
985: SUBROUTINE FINDROTATIONS(OVERLAP, L, ANGLES, AMPLITUDES, NROTATIONS, DEBUG) 
986: ! Fits a set of Gaussians to the overlap integral and calculates the Euler angles these correspond to 
987:  
988: USE FASTOVERLAPUTILS, ONLY: FINDPEAKS 
989:  
990: IMPLICIT NONE 
991:  
992: INTEGER, INTENT(IN) :: L 
993: INTEGER, INTENT(INOUT) :: NROTATIONS 
994: LOGICAL, INTENT(IN) :: DEBUG 
995: DOUBLE PRECISION, INTENT(IN) :: OVERLAP(2*L+2,2*L+2,2*L+2) 
996: DOUBLE PRECISION, INTENT(OUT) :: ANGLES(NROTATIONS,3), AMPLITUDES(NROTATIONS) 
997:  
998: DOUBLE PRECISION CONVERT 
999: INTEGER J 
1000:  
1001: ANGLES=0.D0 
1002:  
1003: CALL FINDPEAKS(OVERLAP, ANGLES, AMPLITUDES, NROTATIONS, DEBUG) 
1004:  
1005: ! Convert index locations to Euler Angles 
1006: CONVERT = PI / (2*L+2) 
1007: ANGLES(:NROTATIONS,1) = (ANGLES(:NROTATIONS,1)-1.0D0) * 2 * CONVERT 
1008: ANGLES(:NROTATIONS,2) = (ANGLES(:NROTATIONS,2)-0.5D0) * CONVERT 
1009: ANGLES(:NROTATIONS,3) = (ANGLES(:NROTATIONS,3)-1.0D0) * 2 * CONVERT 
1010:  
1011: END SUBROUTINE FINDROTATIONS 
1012:  
1013: SUBROUTINE EULERM(A,B,G,ROTM) 
1014: ! Calculates rotation matrix of the Euler angles A,B,G 
1015: IMPLICIT NONE 
1016:  
1017: DOUBLE PRECISION, INTENT(IN) :: A,B,G 
1018: DOUBLE PRECISION, INTENT(OUT) :: ROTM(3,3) 
1019:  
1020: DOUBLE PRECISION  COSA, SINA, COSB, SINB, COSG, SING 
1021:  
1022: COSA = COS(A) 
1023: SINA = SIN(A) 
1024: COSB = COS(B) 
1025: SINB = SIN(B) 
1026: COSG = COS(G) 
1027: SING = SIN(G) 
1028:  
1029:   ROTM (1,1) =   COSG * COSB * COSA  -  SING * SINA 
1030:   ROTM (1,2) = + SING * COSB * COSA  +  COSG * SINA 
1031:   ROTM (1,3) =          SINB * COSA 
1032:   ROTM (2,1) = - COSG * COSB * SINA  -  SING * COSA 
1033:   ROTM (2,2) = - SING * COSB * SINA  +  COSG * COSA 
1034:   ROTM (2,3) = -        SINB * SINA 
1035:   ROTM (3,1) = - COSG * SINB 
1036:   ROTM (3,2) = - SING * SINB 
1037:   ROTM (3,3) =          COSB 
1038:  
1039: END SUBROUTINE EULERM 
1040:  
1041: SUBROUTINE EULERINVM(A,B,G,ROTM) 
1042: ! Calculates inverse (transposed) rotation matrix of the Euler angles A,B,G 
1043: IMPLICIT NONE 
1044:  
1045: DOUBLE PRECISION, INTENT(IN) :: A,B,G 
1046: DOUBLE PRECISION, INTENT(OUT) :: ROTM(3,3) 
1047:  
1048: DOUBLE PRECISION  COSA, SINA, COSB, SINB, COSG, SING 
1049:  
1050: COSA = COS(A) 
1051: SINA = SIN(A) 
1052: COSB = COS(B) 
1053: SINB = SIN(B) 
1054: COSG = COS(G) 
1055: SING = SIN(G) 
1056:  
1057:   ROTM (1,1) =   COSG * COSB * COSA  -  SING * SINA 
1058:   ROTM (2,1) =   SING * COSB * COSA  +  COSG * SINA 
1059:   ROTM (3,1) =          SINB * COSA 
1060:   ROTM (1,2) = - COSG * COSB * SINA  -  SING * COSA 
1061:   ROTM (2,2) = - SING * COSB * SINA  +  COSG * COSA 
1062:   ROTM (3,2) = -        SINB * SINA 
1063:   ROTM (1,3) = - COSG * SINB 
1064:   ROTM (2,3) = - SING * SINB 
1065:   ROTM (3,3) =          COSB 
1066:  
1067: END SUBROUTINE EULERINVM 
1068:  
1069: SUBROUTINE CHOOSE_KWIDTH(NCOORDS, COORDSA, COORDSB, KWIDTH, DEBUG) 
1070: ! Calculate a reasonable default kernel width for the current alignment problem. 
1071: ! KWIDTH is set to 1/3 times the average nearest-neighbour separation in the two clusters. 
1072: ! For each atom in each structure, the closest other atom is identified. The distance to these closest atoms is averaged across 
1073: ! all atoms and both structures. 
1074:  
1075: IMPLICIT NONE 
1076:  
1077: INTEGER, INTENT(IN)           :: NCOORDS 
1078: DOUBLE PRECISION, INTENT(IN)  :: COORDSA(3*NCOORDS), COORDSB(3*NCOORDS) 
1079: DOUBLE PRECISION, INTENT(OUT) :: KWIDTH 
1080: LOGICAL, INTENT(IN)           :: DEBUG 
1081:  
1082: INTEGER          :: J1, J2 
1083: DOUBLE PRECISION :: DIST, MIN_DIST, SUM_MINDISTS 
1084:  
1085: SUM_MINDISTS = 0.0D0 
1086:  
1087: ! Find average NN distance for structure A 
1088: DO J1 = 1, NCOORDS  ! Find the nearest-neighbour distance of atom J1 
1089:    MIN_DIST = 1.0D10 
1090:    DO J2 = 1, NCOORDS  ! Check all the neighbours of J1 
1091:       IF (J1.EQ.J2) CYCLE 
1092:  
1093:       DIST = SQRT((COORDSA(3*(J1-1)+1)-COORDSA(3*(J2-1)+1))**2 +   & 
1094:     &             (COORDSA(3*(J1-1)+2)-COORDSA(3*(J2-1)+2))**2 +   & 
1095:     &             (COORDSA(3*(J1-1)+3)-COORDSA(3*(J2-1)+3))**2) 
1096:       IF (DIST .LT. MIN_DIST) THEN 
1097:          MIN_DIST = DIST 
1098:       ENDIF 
1099:    ENDDO 
1100:    SUM_MINDISTS = SUM_MINDISTS + MIN_DIST 
1101: ENDDO 
1102:  
1103: ! Find average NN distance for structure B 
1104: DO J1 = 1, NCOORDS  ! Find the nearest-neighbour distance of atom J1 
1105:    MIN_DIST = 1.0D10 
1106:    DO J2 = 1, NCOORDS  ! Check all the neighbours of J1 
1107:       IF (J1.EQ.J2) CYCLE 
1108:  
1109:       DIST = SQRT((COORDSB(3*(J1-1)+1)-COORDSB(3*(J2-1)+1))**2 +   & 
1110:     &             (COORDSB(3*(J1-1)+2)-COORDSB(3*(J2-1)+2))**2 +   & 
1111:     &             (COORDSB(3*(J1-1)+3)-COORDSB(3*(J2-1)+3))**2) 
1112:       IF (DIST .LT. MIN_DIST) THEN 
1113:          MIN_DIST = DIST 
1114:       ENDIF 
1115:    ENDDO 
1116:    SUM_MINDISTS = SUM_MINDISTS + MIN_DIST 
1117: ENDDO 
1118:  
1119: KWIDTH = SUM_MINDISTS/(3*2*NCOORDS) ! 2*NCOORDS is the number of pairs over which we have averaged. 
1120:                                      ! Divide by 3 so that KWIDTH is 1/3 of the average separation 
1121:  
1122: IF(DEBUG) write(*,*) "fastclusters> Determined an appropriate value for KWIDTH:", KWIDTH 
1123:  
1124: END SUBROUTINE CHOOSE_KWIDTH 
1125:  
1126: SUBROUTINE CHECKKEYWORDS() 
1127:  
1128: USE KEY, ONLY : NFREEZE,GEOMDIFFTOL,ORBITTOL,FREEZE,PULLT,TWOD,  & 
1129:     &   EFIELDT,AMBERT,QCIAMBERT,AMBER12T,STOCKT,PERMDIST,      & 
1130:     &   LOCALPERMDIST,LPERMDIST,OHCELLT,QCIPERMCHECK,    & 
1131:     &   NOINVERSION,GTHOMSONT,MKTRAPT,RIGIDBODY,OHCELLT 
1132:  
1133: IMPLICIT NONE 
1134:  
1135: IF ((.NOT.ALLOCATED(PERMGROUP)).OR.(.NOT.ALLOCATED(NPERMSIZE))) THEN 
1136:     WRITE(*,'(A)') 'ERROR - permutation arrays not set, use PERMDIST keyword' 
1137:     STOP 
1138: ENDIF 
1139:  
1140: IF (OHCELLT) THEN 
1141:     WRITE(*,'(A)') 'ERROR - cluster fastoverlap not compatible with OHCELL keyword' 
1142:     STOP 
1143: ENDIF 
1144:  
1145: IF(STOCKT) THEN 
1146:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with STOCK keyword' 
1147:     STOP 
1148: ENDIF 
1149:  
1150: IF(PULLT) THEN 
1151:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with PULL keyword' 
1152:     STOP 
1153: ENDIF 
1154:  
1155: IF(EFIELDT) THEN 
1156:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with EFIELD keyword' 
1157:     STOP 
1158: ENDIF 
1159:  
1160: IF(RIGIDBODY) THEN 
1161:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with RIGIDBODY keyword' 
1162:     STOP 
1163: ENDIF 
1164:  
1165: IF(QCIPERMCHECK) THEN 
1166:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with QCIPERMCHECK keyword' 
1167:     STOP 
1168: ENDIF 
1169:  
1170: IF(QCIAMBERT) THEN 
1171:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with QCIAMBER keyword' 
1172:     STOP 
1173: ENDIF 
1174:  
1175: IF(GTHOMSONT) THEN 
1176:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with GTHOMSON keyword' 
1177:     STOP 
1178: ENDIF 
1179:  
1180: IF(MKTRAPT) THEN 
1181:     WRITE(*,'(A)') 'ERROR - fastoverlap not compatible with MKTRAP keyword' 
1182:     STOP 
1183: ENDIF 
1184:  
1185: END SUBROUTINE CHECKKEYWORDS 
1186:  
1187: END MODULE CLUSTERFASTOVERLAP 
1188:  
1189: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
1190:  
1191: ! INCLUDE "bulkmindist.f90" 
1192: ! INCLUDE "minpermdist.f90" 
1193: ! INCLUDE "minperm.f90" 
1194: ! INCLUDE "newmindist.f90" 
1195: ! INCLUDE "orient.f90" 
1196: ! INCLUDE "legendre.f90" 


r33371/fastutils.f90 2017-10-04 18:30:08.796193452 +0100 r33370/fastutils.f90 2017-10-04 18:30:12.332240098 +0100
  1: !    FASTOVERLAP  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/OPTIM/source/ALIGN/fastutils.f90' in revision 33370
  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:  
 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(). 
 21: !    Functions: 
 22: !      rlegendrel0 = rlegendrel0(l,z) 
 23: !      rlegendrem0 = rlegendrem0(m,l,z) 
 24: !      rlegendrem1 = rlegendrem1(m,l,z) 
 25: !      envj = envj(n,x) 
 26: !      msta1 = msta1(x,mp) 
 27: !      msta2 = msta2(x,n,mp) 
 28: !      nm,si = sphi(n,x) 
 29: !      hg = hyp1f1(ain,bin,xin) 
 30: !      ga = gamma(x) 
 31: !      fvec,fjac,info,nfev,njev,qtf = lmder(fcn,m,x,ldfjac,ftol,xtol,gtol,maxfev,diag,mode,factor,nprint,ipvt,n=len(x),fcn_extra_args=()) 
 32: !      fvec,fjac,info = lmder1(fcn,m,x,ldfjac,tol,n=len(x),fcn_extra_args=()) 
 33: !      enorm = enorm(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)) 
 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)) 
 38: !      xmed = median(x,n=len(x)) 
 39:  
 40: MODULE FASTOVERLAPUTILS 
 41:  
 42: !*********************************************************************** 
 43: ! This module contains some subroutines that are useful for FASTOVERLAP 
 44: ! alignment for both periodic and isolated structures 
 45: !*********************************************************************** 
 46: ! Subroutines: 
 47: !     Permutations Routines 
 48: !         SETPERM 
 49: !     Peakfinding subroutines: 
 50: !         SETINDEXES 
 51: !         SETFSPACE 
 52: !         GAUSSIAN 
 53: !         FCN 
 54: !         FIT 
 55: !         FINDPEAK 
 56: !         FINDPEAKS 
 57: !     FFT subroutines 
 58: !         FFT3D 
 59: !         IFFT3D 
 60: !         FFT1D 
 61: !         IFFT1D 
 62: !*********************************************************************** 
 63: USE ALIGNUTILS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP, NATOMS, BESTPERM, NSETS, SETS 
 64: USE FFTW3 
 65: USE PREC, ONLY: INT64, REAL64 
 66:  
 67: IMPLICIT NONE 
 68:  
 69: ! Variables and arrays needed for peakfinding 
 70: INTEGER, PARAMETER :: DEFAULTWIDTH=2 
 71: DOUBLE PRECISION, PARAMETER :: DEFAULTTOL=1.D-6 
 72: INTEGER, SAVE :: FSIZE, FSHAPE(3) 
 73: DOUBLE PRECISION, SAVE, ALLOCATABLE :: FSPACE(:,:,:),FSPACECOPY(:,:,:),GAUSARRAY(:,:,:),FVEC(:),FJAC(:,:) 
 74:  
 75: !! Stuff for permutational alignment 
 76: DOUBLE PRECISION, SAVE, ALLOCATABLE :: PDUMMYA(:), PDUMMYB(:), DUMMYA(:), DUMMYB(:), XBESTA(:), XBESTASAVE(:) 
 77: INTEGER, SAVE, ALLOCATABLE :: NEWPERM(:), LPERM(:) 
 78:  
 79: ! 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:     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:     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:     90, 90, 90, 90, 90, 96, 96, 96, 96, 96, 96, 100, 100, 100, 100, 108, 108, & 
 86:     108, 108, 108, 108, 108, 108, 120, 120, 120, 120, 120, 120, 120, 120, 120,& 
 87:     120, 120, 120, 125, 125, 125, 125, 125, 128, 128, 128, 135, 135, 135, 135,& 
 88:     135, 135, 135, 144, 144, 144, 144, 144, 144, 144, 144, 144, 150, 150, 150,& 
 89:     150, 150, 150, 160, 160, 160, 160, 160, 160, 160, 160, 160, 160, 162, 162,& 
 90:     180, 180, 180, 180, 180, 180, 180, 180, 180, 180, 180, 180, 180, 180, 180,& 
 91:     180, 180, 180, 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 192,& 
 92:     200, 200, 200, 200, 200, 200, 200, 200/) 
 93:  
 94: CONTAINS 
 95:  
 96: SUBROUTINE SETNATOMS(NEWNATOMS) 
 97: ! Checks if arrays need to be (re)allocated 
 98: IMPLICIT NONE 
 99:  
100: INTEGER, INTENT(IN) :: NEWNATOMS 
101:  
102: IF((.NOT.ALLOCATED(PERMGROUP)).OR.(.NOT.ALLOCATED(NPERMSIZE))) THEN 
103:     WRITE(*,'(A)') 'ERROR - permutation arrays not set, use PERMDIST keyword' 
104:     STOP 
105: ENDIF 
106:  
107: IF(.NOT.(SIZE(PDUMMYA).EQ.(3*NEWNATOMS))) THEN 
108:     IF(ALLOCATED(PDUMMYA)) THEN 
109:         DEALLOCATE(PDUMMYA,PDUMMYB,DUMMYA,DUMMYB,XBESTA,XBESTASAVE) 
110:         DEALLOCATE(NEWPERM, LPERM) 
111:     ENDIF 
112:     ALLOCATE(PDUMMYA(3*NEWNATOMS),PDUMMYB(3*NEWNATOMS),DUMMYA(3*NEWNATOMS), & 
113:     &   DUMMYB(3*NEWNATOMS), XBESTA(3*NEWNATOMS), XBESTASAVE(3*NEWNATOMS)) 
114:     ALLOCATE(NEWPERM(NEWNATOMS), LPERM(NEWNATOMS)) 
115: ENDIF 
116:  
117: END SUBROUTINE SETNATOMS 
118:  
119: SUBROUTINE SETPERM(NEWNATOMS, NEWPERMGROUP, NEWNPERMSIZE) 
120: ! Not needed for GMIN/OPTIM/PATHSAMPLE 
121: ! (Re)allocates arrays that define allowed permuations 
122: IMPLICIT NONE 
123:  
124: INTEGER, INTENT(IN) :: NEWNATOMS, NEWPERMGROUP(:), NEWNPERMSIZE(:) 
125:  
126: IF(.NOT.SIZE(PERMGROUP).EQ.SIZE(NEWPERMGROUP)) THEN 
127:     IF(ALLOCATED(PERMGROUP)) THEN 
128:         DEALLOCATE(PERMGROUP) 
129:     ENDIF 
130:     ALLOCATE(PERMGROUP(SIZE(NEWPERMGROUP))) 
131: ENDIF 
132:  
133: NPERMGROUP = SIZE(NEWNPERMSIZE) 
134: IF(.NOT.SIZE(NPERMSIZE).EQ.SIZE(NEWNPERMSIZE)) THEN 
135:     IF(ALLOCATED(NPERMSIZE)) THEN 
136:         DEALLOCATE(NPERMSIZE) 
137:     ENDIF 
138:     ALLOCATE(NPERMSIZE(NPERMGROUP)) 
139: ENDIF 
140:  
141: IF(.NOT.SIZE(BESTPERM).EQ.NEWNATOMS) THEN 
142:     IF(ALLOCATED(BESTPERM)) THEN 
143:         DEALLOCATE(BESTPERM) 
144:     ENDIF 
145:     ALLOCATE(BESTPERM(NEWNATOMS)) 
146: ENDIF 
147:  
148: IF(.NOT.SIZE(NSETS).EQ.(3*NEWNATOMS)) THEN 
149:     IF(ALLOCATED(NSETS)) THEN 
150:         DEALLOCATE(NSETS) 
151:     ENDIF 
152:     ALLOCATE(NSETS(3*NEWNATOMS)) 
153: ENDIF 
154:  
155: IF(.NOT.SIZE(SETS).EQ.(3*NEWNATOMS*70)) THEN 
156:     IF(ALLOCATED(SETS)) THEN 
157:         DEALLOCATE(SETS) 
158:     ENDIF 
159:     ALLOCATE(SETS(3*NEWNATOMS,70)) 
160: ENDIF 
161:  
162: NATOMS = NEWNATOMS 
163: PERMGROUP = NEWPERMGROUP 
164: NPERMSIZE = NEWNPERMSIZE 
165: NSETS = 0 
166:  
167: CALL SETNATOMS(NEWNATOMS) 
168:  
169: END SUBROUTINE SETPERM 
170:  
171: SUBROUTINE SETINDEXES(NEWSHAPE) 
172:  
173: ! Helper routine to allocate memory to appropriate arrays needed to perform 
174: ! Levenberg-Marquardt non-linear least-squares curve fitting to find peaks 
175:  
176: IMPLICIT NONE 
177:  
178: INTEGER, INTENT(IN) :: NEWSHAPE(3) 
179:  
180: IF (.NOT.ALL(FSHAPE.EQ.NEWSHAPE)) THEN 
181:     FSHAPE = NEWSHAPE 
182:     IF(ALLOCATED(FSPACE))  DEALLOCATE(FSPACE) 
183:     IF(ALLOCATED(FVEC))  DEALLOCATE(FVEC) 
184:     IF(ALLOCATED(FJAC)) DEALLOCATE(FJAC) 
185:  
186:     ALLOCATE( FSPACE( FSHAPE(1),FSHAPE(2),FSHAPE(3) ) ) 
187:     FSIZE = SIZE(FSPACE) 
188:  
189:     ALLOCATE(FVEC(FSIZE)) 
190:     ALLOCATE(FJAC(11,FSIZE)) 
191: ENDIF 
192:  
193: END SUBROUTINE SETINDEXES 
194:  
195: !*********************************************************************** 
196:  
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) 
217:  
218: IMPLICIT NONE 
219:  
220: !INTEGER, INTENT(IN) :: NX,NY,NZ 
221: DOUBLE PRECISION, INTENT(IN), DIMENSION(:,:,:) :: NEWFSPACE 
222: !INTEGER NSHAPE(3) 
223:  
224: !NSHAPE=(/NX,NY,NZ/) 
225: CALL SETINDEXES(SHAPE(NEWFSPACE)) 
226:  
227: FSPACE = NEWFSPACE 
228:  
229: END SUBROUTINE SETFSPACE 
230:  
231: !*********************************************************************** 
232:  
233: SUBROUTINE GAUSSIAN(X,NX,NY,NZ,FOUT) 
234:  
235: ! Routine to calculate the values of a 3-D gaussian 
236: ! FOUT(IX, IY, IZ) = A * Exp(-(I-I0)^T SIGMA (I-I0)) 
237: ! I = (/IX, IY, IZ/) 
238: !specified by the parameter vector X: 
239: ! 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) \) 
240:  
241: IMPLICIT NONE 
242:  
243: INTEGER, INTENT(IN) :: NX, NY, NZ 
244: DOUBLE PRECISION, INTENT(IN), DIMENSION(:) :: X 
245: DOUBLE PRECISION, INTENT(OUT) :: FOUT(NX,NY,NZ) 
246:  
247: INTEGER IX,IY,IZ,J 
248: DOUBLE PRECISION SIGMA(3,3), A, MEAN, Y, EXPY, FY, IND0(3), DY(3) 
249:  
250: A = X(1) 
251: MEAN = X(2) 
252: SIGMA(1,1) = X(3) 
253: SIGMA(2,2) = X(4) 
254: SIGMA(3,3) = X(5) 
255: SIGMA(1,2) = X(6) 
256: SIGMA(2,1) = 0.D0!X(6) 
257: SIGMA(2,3) = X(7) 
258: SIGMA(3,2) = 0.D0!X(7) 
259: SIGMA(1,3) = X(8) 
260: SIGMA(3,1) = 0.D0!X(8) 
261: !IND0 = X(9:11) 
262:  
263: DO IZ=1,NZ 
264:     DO IY=1,NY 
265:         DO IX=1,NX 
266:             IND0 = (/IX,IY,IZ/) - X(9:11) 
267:             DO J=1,3 
268:                 DY(J) = SUM(SIGMA(J,:)*IND0) 
269:             ENDDO 
270:             Y = SUM(IND0*DY) 
271:             EXPY = EXP(-Y) 
272:             FOUT(IX,IY,IZ) =  (A*EXPY + MEAN) 
273:         ENDDO 
274:     ENDDO 
275: ENDDO 
276:  
277: END SUBROUTINE GAUSSIAN 
278:  
279: !*********************************************************************** 
280:  
281: SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) 
282:  
283: ! 
284: ! subroutine passed to lmder1 to perform least squares regression, minimizing 
285: ! SUM((FOUT - FSPACE)**2) 
286: ! where  FOUT(IX, IY, IZ) = A * Exp(-(I-I0)^T SIGMA (I-I0)) 
287: ! I = (/IX, IY, IZ/) 
288: !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) \) 
290: ! M = SIZE(FSPACE) is the number of observations 
291: ! LDFJAC = N specifies the dimension of the jacobian matrix 
292: ! N = 11 is the number of parameters to optimise 
293: ! If IFLAG=1 then calculates FVEC, the vector of square difference of each observation 
294: ! If IFLAG=2 then calculates FVEC and FJAC, the jacobian maxtrix of FVEC 
295:  
296: IMPLICIT NONE 
297:  
298: INTEGER, INTENT(IN) :: LDFJAC, N, M, IFLAG 
299: DOUBLE PRECISION, INTENT(OUT) :: FJAC(LDFJAC, N), FVEC(M) 
300: DOUBLE PRECISION, INTENT(INOUT) :: X(N) 
301:  
302: DOUBLE PRECISION SIGMA(3,3), A, MEAN, Y, EXPY, FY, DIFF, DY(3), IND0(3) 
303: INTEGER :: I,J,K,IND(3)!,IX,IY,IZ!,S(2)=(/3,1/) 
304:  
305: ! if IFLAG =/= 1/2 then do nothing... 
306: IF(IFLAG.EQ.1 .OR. IFLAG.EQ.2) THEN 
307: A = X(1) 
308: MEAN = X(2) 
309: SIGMA(1,1) = X(3) 
310: SIGMA(2,2) = X(4) 
311: SIGMA(3,3) = X(5) 
312: SIGMA(1,2) = X(6) 
313: SIGMA(2,1) = 0.D0!X(6) 
314: SIGMA(2,3) = X(7) 
315: SIGMA(3,2) = 0.D0!X(7) 
316: SIGMA(1,3) = X(8) 
317: SIGMA(3,1) = 0.D0!X(8) 
318: !IND0 = X(9:11) 
319:  
320: DO I=1,M 
321:     !Some pointer arithmetic to get the 3D index location 
322:     !I miss 0-indexing 
323:     IND(1) = (I-1)/FSHAPE(2)/FSHAPE(3) + 1 
324:     IND(2) = MOD((I-1)/FSHAPE(3), FSHAPE(2)) + 1 
325:     IND(3) = MOD(I-1, FSHAPE(3)) + 1 
326:     IND0 = IND - X(9:11) 
327:     !Y = 0.D0 
328:     DO J=1,3 
329:         DY(J) = SUM(SIGMA(J,:)*IND0) 
330:     ENDDO 
331:     Y = SUM(IND0*DY) 
332:     EXPY = EXP(-Y) 
333:     FY = (A*EXPY + MEAN) 
334:     DIFF = (FY - FSPACE(IND(1),IND(2),IND(3))) 
335:     FVEC(I) = DIFF**2 
336:     IF(IFLAG.EQ.2) THEN 
337:         ! Calculating Jacobian 
338:         FJAC(I,1) = 2 * EXPY * DIFF 
339:         FJAC(I,2) = 2 * DIFF 
340:         FJAC(I,3) = -(IND0(1)*IND0(1))*A*EXPY * DIFF * 2 
341:         FJAC(I,4) = -(IND0(2)*IND0(2))*A*EXPY * DIFF * 2 
342:         FJAC(I,5) = -(IND0(3)*IND0(3))*A*EXPY * DIFF * 2 
343:         FJAC(I,6) = -(IND0(1)*IND0(2))*A*EXPY * DIFF * 2 
344:         FJAC(I,7) = -(IND0(2)*IND0(3))*A*EXPY * DIFF * 2 
345:         FJAC(I,8) = -(IND0(1)*IND0(3))*A*EXPY * DIFF * 2 
346:         FJAC(I,9:11) = 4 * DY * A * EXPY * DIFF 
347:     ENDIF 
348: ENDDO 
349: ENDIF 
350:  
351: END SUBROUTINE FCN 
352:  
353: !*********************************************************************** 
354:  
355: SUBROUTINE FIT(X, NEWFSPACE, NX, NY, NZ, INFO, TOL) 
356:  
357: ! This fits a 3 dimensional gaussian of the form 
358: ! A exp (- (I-I0)T Sigma (I-I0) ) + mean 
359: ! Where I is the 3-D vector of the indexes 
360: ! To the 3 dimensional array specified by FSPACE 
361: ! This uses the Levenberg-Marquardt method. 
362: ! Usage: 
363: ! 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) \) 
365: !INFO is set as follows: 
366: !    0, improper input parameters. 
367: !    1, algorithm estimates that the relative error in the sum of squares 
368: !       is at most TOL. 
369: !    2, algorithm estimates that the relative error between X and the 
370: !       solution is at most TOL. 
371: !    3, conditions for INFO = 1 and INFO = 2 both hold. 
372: !    4, FVEC is orthogonal to the columns of the jacobian to machine precision. 
373: !    5, number of calls to FCN with IFLAG = 1 has reached 100*(N+1). 
374: !    6, TOL is too small.  No further reduction in the sum of squares is 
375: !       possible. 
376: !    7, TOL is too small.  No further improvement in the approximate 
377: !       solution X is possible. 
378:  
379: IMPLICIT NONE 
380:  
381: INTEGER, INTENT(IN) :: NX,NY,NZ 
382: DOUBLE PRECISION, INTENT(IN) :: NEWFSPACE(NX,NY,NZ) 
383: DOUBLE PRECISION, INTENT(IN), OPTIONAL :: TOL 
384: DOUBLE PRECISION, INTENT(INOUT), DIMENSION(:) :: X 
385: INTEGER, INTENT(OUT) :: INFO 
386:  
387: DOUBLE PRECISION USETOL 
388:  
389: IF (PRESENT(TOL)) THEN 
390:     USETOL = TOL 
391: ELSE 
392:     USETOL = DEFAULTTOL 
393: ENDIF 
394:  
395: CALL SETFSPACE(NEWFSPACE) 
396: !Perform Levenberg-Marquardt non-linear least square regression 
397: CALL LMDER1 (FCN, FSIZE, 11, X, FVEC, FJAC, FSIZE, USETOL, INFO) 
398:  
399: END SUBROUTINE FIT 
400:  
401: !*********************************************************************** 
402:  
403: SUBROUTINE FINDPEAK (A, WIDTH, X, INFO, TOL, AMAX) 
404:  
405: ! Finds maximum value of 3D array A Selects the indexes within WIDTH 
406: ! Fits Gaussian to these indexes, then outputs the fit as X 
407:  
408: ! ASSUMES PERIODIC BOUNDARY CONDITIONS 
409:  
410: IMPLICIT NONE 
411:  
412: DOUBLE PRECISION, INTENT(IN), DIMENSION(:,:,:) :: A 
413: DOUBLE PRECISION, INTENT(IN), OPTIONAL :: TOL 
414: INTEGER, INTENT(IN) :: WIDTH 
415: DOUBLE PRECISION, INTENT(OUT) :: X(11) 
416: INTEGER, INTENT(OUT) :: INFO, AMAX(3) 
417:  
418: DOUBLE PRECISION FSPACE(WIDTH*2+1,WIDTH*2+1,WIDTH*2+1) 
419: DOUBLE PRECISION MAXA, MEANA 
420: INTEGER ASHAPE(3),I1,I2,I3,IND(3) !AMAX(3) 
421:  
422: AMAX = MAXLOC(A) 
423: MEANA = SUM(A)/SIZE(A) 
424: MAXA = MAXVAL(A) - MEANA 
425: ! initialise guess for parameter array 
426: X = (/MAXA,MEANA,1.D0,1.D0,1.D0,0.D0,0.D0,0.D0,WIDTH+1.D0,WIDTH+1.D0,WIDTH+1.D0/) 
427: ASHAPE = SHAPE(A) 
428:  
429: ! selecting subarray to fit peak to 
430: DO I3=1,2*WIDTH+1 
431:     DO I2=1,2*WIDTH+1 
432:         DO I1=1,2*WIDTH+1 
433:             ! Ensures periodic boundary conditions 
434:             IND = MODULO(AMAX+(/I1,I2,I3/)-2-WIDTH,ASHAPE) + 1 
435:             FSPACE(I1,I2,I3) = A(IND(1),IND(2),IND(3)) 
436:         ENDDO 
437:     ENDDO 
438: ENDDO 
439:  
440: IF(PRESENT(TOL)) THEN 
441:     CALL FIT(X, FSPACE, WIDTH*2+1, WIDTH*2+1, WIDTH*2+1,INFO, TOL) 
442: ELSE 
443:     CALL FIT(X, FSPACE, WIDTH*2+1, WIDTH*2+1, WIDTH*2+1, INFO) 
444: ENDIF 
445:  
446: END SUBROUTINE FINDPEAK 
447:  
448: !*********************************************************************** 
449:  
450: SUBROUTINE PRINTLMDERERROR(INFO) 
451:  
452: IMPLICIT NONE 
453:  
454: INTEGER, INTENT(IN) :: INFO 
455:  
456: SELECT CASE (INFO) 
457: CASE(0) 
458:     WRITE(*,'(A)') "  improper input parameters." 
459: CASE(1) 
460:     WRITE(*,'(A)') "  algorithm estimates that the relative error in the sum of squares is at most TOL." 
461: CASE(2) 
462:     WRITE(*,'(A)') "  algorithm estimates that the relative error between X and the solution is at most TOL." 
463: CASE(3) 
464:     WRITE(*,'(A)') "  conditions for INFO = 1 and INFO = 2 both hold." 
465: CASE(4) 
466:     WRITE(*,'(A)') "  FVEC is orthogonal to the columns of the jacobian to machine precision." 
467: CASE(5) 
468:     WRITE(*,'(A)') "  number of calls to FCN with IFLAG = 1 has reached 100*(N+1)." 
469: CASE(6) 
470:     WRITE(*,'(A)') "  TOL is too small.  No further reduction in the sum of squares is possible." 
471: CASE(7) 
472:     WRITE(*,'(A)') "  TOL is too small.  No further improvement in the approximate solution X is possible. " 
473: END SELECT 
474:  
475: END SUBROUTINE PRINTLMDERERROR 
476:  
477: SUBROUTINE FINDPEAKS(FSPACE, PEAKS, AMPLITUDES, NPEAKS, DEBUG) 
478:  
479: ! This finds up to npeaks of a 3D periodic array 
480: ! The locations are returned in peaks as fractional index coordinates 
481: ! Amplitude gives the relative amplitude of each of the peaks 
482: ! NPEAKS gives the actual number of peaks found 
483:  
484: IMPLICIT NONE 
485:  
486: DOUBLE PRECISION, INTENT(IN), DIMENSION(:,:,:) :: FSPACE 
487: INTEGER, INTENT(INOUT) :: NPEAKS 
488: LOGICAL, INTENT(IN) :: DEBUG 
489: !INTEGER, INTENT(IN), OPTIONAL :: WIDTH 
490: DOUBLE PRECISION, INTENT(OUT) :: PEAKS(NPEAKS,3), AMPLITUDES(NPEAKS) 
491:  
492: INTEGER WIDTH, NFOUND, FSHAPE(3), INFO, N, FMAX(3) 
493: DOUBLE PRECISION T, X(11), PEAK(3) 
494: DOUBLE PRECISION, ALLOCATABLE :: FSPACECOPY(:,:,:), GAUSARRAY(:,:,:) 
495:  
496: WIDTH = DEFAULTWIDTH 
497: FSHAPE = SHAPE(FSPACE) 
498:  
499: IF (.NOT.ALL(SHAPE(FSPACECOPY).EQ.FSHAPE)) THEN 
500:     IF(ALLOCATED(FSPACECOPY))  DEALLOCATE(FSPACECOPY) 
501:     IF(ALLOCATED(GAUSARRAY)) DEALLOCATE(GAUSARRAY) 
502:     ALLOCATE(FSPACECOPY(FSHAPE(1),FSHAPE(2),FSHAPE(3)),GAUSARRAY(FSHAPE(1),FSHAPE(2),FSHAPE(3))) 
503: ENDIF 
504:  
505: FSPACECOPY = FSPACE 
506:  
507: NFOUND = 0 
508: DO WHILE(NFOUND.EQ.0) 
509:     DO N=1,NPEAKS 
510:         CALL FINDPEAK(FSPACECOPY, WIDTH, X, INFO, DEFAULTTOL, FMAX) 
511:  
512:         IF(INFO.EQ.0.OR.INFO.EQ.5) THEN 
513:             IF (DEBUG) THEN 
514:                 WRITE(*,'(A)') "fastoverlaputils> WARNING - FINDPEAK failed with error:" 
515:                 CALL PRINTLMDERERROR(INFO) 
516:             ENDIF 
517:             EXIT 
518:         ELSE 
519:             IF(INFO.EQ.4.OR.INFO.EQ.6.OR.INFO.EQ.7) THEN 
520:                 IF (DEBUG) THEN 
521:                     WRITE(*,'(A)') "fastoverlaputils> WARNING - FINDPEAK ended with message" 
522:                     CALL PRINTLMDERERROR(INFO) 
523:                 ENDIF 
524:             ENDIF 
525: ! Find the location of the peak and subtract this peak from the copy of the data 
526:             NFOUND = NFOUND + 1 
527:             PEAK = (X(9:11) - WIDTH - 1 + FMAX) 
528:             PEAKS(N,:) = PEAK 
529:             AMPLITUDES(N) = X(1) 
530:             X(9:11) = PEAK 
531:             CALL GAUSSIAN(X,FSHAPE(1),FSHAPE(2),FSHAPE(3),GAUSARRAY) 
532:             FSPACECOPY = FSPACECOPY - GAUSARRAY 
533:         ENDIF 
534:     ENDDO 
535:     ! If we've failed to find any peaks, increase the size of the box and start again 
536:     IF (NFOUND.EQ.0) THEN 
537:         WIDTH = WIDTH + 1 
538:         IF (WIDTH.GT.(MINVAL(FSHAPE)/2)) THEN 
539:             WRITE(*,'(A)')  "ERROR fastoverlaputils-FINDPEAKS subroutine failed to find any peaks" 
540:             STOP 
541:         ENDIF 
542:     ENDIF 
543: ENDDO 
544:  
545: NPEAKS = NFOUND 
546:  
547: !DEALLOCATE(FSPACECOPY) 
548: !DEALLOCATE(GAUSARRAY) 
549:  
550: END SUBROUTINE FINDPEAKS 
551:  
552: !*********************************************************************** 
553: ! FFT subroutines 
554: !*********************************************************************** 
555:  
556: SUBROUTINE FFT3D(NX, NY, NZ, IN, OUT) 
557: ! calculates forward FFT in 3D 
558: IMPLICIT NONE 
559:  
560: INTEGER, INTENT(IN) :: NX, NY, NZ 
561: COMPLEX(KIND=REAL64), INTENT(IN) :: IN(NX, NY, NZ) 
562: COMPLEX(KIND=REAL64), INTENT(OUT) :: OUT(NX, NY, NZ) 
563:  
564: ! INCLUDE "fftw3.f90" 
565: INTEGER(KIND=INT64) PLAN_FORWARD 
566:  
567: CALL DFFTW_PLAN_DFT_3D_(PLAN_FORWARD, NX, NY, NZ, IN, OUT, FFTW_FORWARD, FFTW_ESTIMATE ) 
568: CALL DFFTW_EXECUTE_(PLAN_FORWARD) 
569: !CALL DFFTW_DESTROY_PLAN(PLAN_FORWARD) 
570:  
571: END SUBROUTINE FFT3D 
572:  
573: !*********************************************************************** 
574:  
575: SUBROUTINE IFFT3D(NX, NY, NZ, IN, OUT) 
576:  
577: ! calculates UNNORMALISED inverse fourier transform so, 
578: ! IN == IFFT3D(NX,NY,NZ, FFT3D(NX,NY,NZ, IN))/(NX*NY*NZ) 
579:  
580: IMPLICIT NONE 
581:  
582: INTEGER, INTENT(IN) :: NX, NY, NZ 
583: COMPLEX(KIND=REAL64), INTENT(IN) :: IN(NX, NY, NZ) 
584: COMPLEX(KIND=REAL64), INTENT(OUT) :: OUT(NX, NY, NZ) 
585:  
586: ! INCLUDE "fftw3.f90" 
587: INTEGER(KIND=INT64) PLAN_BACKWARD 
588:  
589: CALL DFFTW_PLAN_DFT_3D_(PLAN_BACKWARD,NX,NY,NZ,IN,OUT,FFTW_BACKWARD,FFTW_ESTIMATE) 
590: CALL DFFTW_EXECUTE_(PLAN_BACKWARD) 
591: CALL DFFTW_DESTROY_PLAN_(PLAN_BACKWARD) 
592:  
593: END SUBROUTINE IFFT3D 
594:  
595: SUBROUTINE FFT1D(N, IN, OUT) 
596: ! calculates forward FFT in 1D 
597:  
598: IMPLICIT NONE 
599:  
600: INTEGER*4, INTENT(IN) :: N 
601: COMPLEX(KIND=REAL64), INTENT(IN) :: IN(N) 
602: COMPLEX(KIND=REAL64), INTENT(OUT) :: OUT(N) 
603:  
604: ! INCLUDE "fftw3.f90" 
605: INTEGER(KIND=INT64) PLAN_FORWARD 
606:  
607: CALL DFFTW_PLAN_DFT_1D_(PLAN_FORWARD, N, IN, OUT, FFTW_FORWARD, FFTW_ESTIMATE ) 
608: CALL DFFTW_EXECUTE_(PLAN_FORWARD) 
609: CALL DFFTW_DESTROY_PLAN_(PLAN_FORWARD) 
610:  
611: END SUBROUTINE FFT1D 
612:  
613: !*********************************************************************** 
614:  
615: SUBROUTINE IFFT1D(N, IN, OUT) 
616:  
617: ! calculates UNNORMALISED inverse fourier transform so, 
618: ! IN == IFFT1D(N, FFT1D(N, IN))/N 
619:  
620: IMPLICIT NONE 
621:  
622: INTEGER*4, INTENT(IN) :: N 
623: COMPLEX(KIND=REAL64), INTENT(IN) :: IN(N) 
624: COMPLEX(KIND=REAL64), INTENT(OUT) :: OUT(N) 
625:  
626: ! INCLUDE "fftw3.f90" 
627: INTEGER(KIND=INT64) PLAN_BACKWARD 
628:  
629: CALL DFFTW_PLAN_DFT_1D_(PLAN_BACKWARD, N, IN, OUT, FFTW_BACKWARD, FFTW_ESTIMATE ) 
630: CALL DFFTW_EXECUTE_(PLAN_BACKWARD) 
631: CALL DFFTW_DESTROY_PLAN_(PLAN_BACKWARD) 
632:  
633: END SUBROUTINE IFFT1D 
634:  
635: SUBROUTINE ARGSORT(A,A2,ARGS,N) 
636:  
637: IMPLICIT NONE 
638:  
639: INTEGER, INTENT(IN) :: N 
640: DOUBLE PRECISION, INTENT(IN) :: A(N) 
641: INTEGER, INTENT(OUT) :: ARGS(N) 
642: DOUBLE PRECISION, INTENT(OUT) :: A2(N) 
643:  
644: DOUBLE PRECISION TEMP2 
645: INTEGER I, IMIN, TEMP1 
646:  
647: DO I = 1, N 
648:     ARGS(I) = I 
649: END DO 
650: A2 = A 
651:  
652: DO I=1,N-1 
653:     IMIN = MINLOC(A2(I:),1) + I - 1 
654:     IF (IMIN.NE.I) THEN 
655:         TEMP2 = A2(I); A2(I) = A2(IMIN); A2(IMIN) = TEMP2 
656:         TEMP1 = ARGS(I); ARGS(I) = ARGS(IMIN); ARGS(IMIN) = TEMP1 
657:     END IF 
658: END DO 
659:  
660: END SUBROUTINE ARGSORT 
661:  
662: !function rargsort(a) result(b) 
663: !! Returns the indices that would sort an array. 
664: !! 
665: !! Arguments 
666: !! --------- 
667: !! 
668: !real(dp), intent(in):: a(:)   ! array of numbers 
669: !integer :: b(size(a))         ! indices into the array 'a' that sort it 
670: !! 
671: !! Example 
672: !! ------- 
673: !! 
674: !! rargsort([4.1_dp, 2.1_dp, 2.05_dp, -1.5_dp, 4.2_dp]) ! Returns [4, 3, 2, 1, 5] 
675: ! 
676: !integer :: N                           ! number of numbers/vectors 
677: !integer :: i,imin                      ! indices: i, i of smallest 
678: !integer :: temp1                       ! temporary 
679: !real(dp) :: temp2 
680: !real(dp) :: a2(size(a)) 
681: !a2 = a 
682: !N=size(a) 
683: !do i = 1, N 
684: !    b(i) = i 
685: !end do 
686: !do i = 1, N-1 
687: !    ! find ith smallest in 'a' 
688: !    imin = minloc(a2(i:),1) + i - 1 
689: !    ! swap to position i in 'a' and 'b', if not already there 
690: !    if (imin /= i) then 
691: !        temp2 = a2(i); a2(i) = a2(imin); a2(imin) = temp2 
692: !        temp1 = b(i); b(i) = b(imin); b(imin) = temp1 
693: !    end if 
694: !end do 
695: !end function 
696:  
697:  
698: END MODULE FASTOVERLAPUTILS 
699:  
700: !*********************************************************************** 
701:  
702: ! Some helper functions for calculating various orthogonal polynomials 
703:  
704: !*********************************************************************** 
705:  
706:  
707: DOUBLE PRECISION FUNCTION RLEGENDREL0(L, Z) 
708:  
709: ! Calcualates recurrence factor M1 for associated legendre polynomials@ 
710: ! P^{L+1}_{L+1} (Z) = L0*P^L_L (Z) 
711:  
712: IMPLICIT NONE 
713: INTEGER, INTENT(IN) :: L 
714: DOUBLE PRECISION, INTENT(IN) :: Z 
715:  
716: RLEGENDREL0 = - (2.D0*L+1) * (1-Z**2)**0.5 
717:  
718: END FUNCTION RLEGENDREL0 
719:  
720:  
721: DOUBLE PRECISION FUNCTION RLEGENDREM0(M, L, Z) 
722: ! 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) 
724:  
725: IMPLICIT NONE 
726: INTEGER, INTENT(IN) :: M, L 
727: DOUBLE PRECISION, INTENT(IN) :: Z 
728:  
729: RLEGENDREM0 = - 2.D0 * M * Z / (1.D0-Z**2)**0.5 / (L+M) / (L-M+1.D0) 
730:  
731: END FUNCTION RLEGENDREM0 
732:  
733: DOUBLE PRECISION FUNCTION RLEGENDREM1(M, L, Z) 
734: ! Calcualates recurrence factor M1 for associated legendre polynomials@ 
735: ! P^{M-1}_L (Z) = M0*P^M_L (Z) + M1*P^{M+1}_L (Z) 
736:  
737: IMPLICIT NONE 
738: INTEGER, INTENT(IN) :: M, L 
739: DOUBLE PRECISION, INTENT(IN) :: Z 
740:  
741: RLEGENDREM1 = - 1.D0 / (L+M) / (L-M+1.D0) 
742:  
743: END FUNCTION RLEGENDREM1 
744:  
745: function envj ( n, x ) 
746:  
747: !*****************************************************************************80 
748: ! 
749: !! ENVJ is a utility function used by MSTA1 and MSTA2. 
750: ! 
751: !  Discussion: 
752: ! 
753: !    ENVJ estimates -log(Jn(x)) from the estimate 
754: !    Jn(x) approx 1/sqrt(2*pi*n) * ( e*x/(2*n))^n 
755: ! 
756: !  Licensing: 
757: ! 
758: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However, 
759: !    they give permission to incorporate this routine into a user program 
760: !    provided that the copyright is acknowledged. 
761: ! 
762: !  Modified: 
763: ! 
764: !    14 January 2016 
765: ! 
766: !  Author: 
767: ! 
768: !    Shanjie Zhang, Jianming Jin 
769: !    Modifications suggested by Vincent Lafage, 11 January 2016. 
770: ! 
771: !  Reference: 
772: ! 
773: !    Shanjie Zhang, Jianming Jin, 
774: !    Computation of Special Functions, 
775: !    Wiley, 1996, 
776: !    ISBN: 0-471-11963-6, 
777: !    LC: QA351.C45. 
778: ! 
779: !  Parameters: 
780: ! 
781: !    Input, integer ( kind = 4 ) N, the order of the Bessel function. 
782: ! 
783: !    Input, real ( kind = 8 ) X, the absolute value of the argument. 
784: ! 
785: !    Output, real ( kind = 8 ) ENVJ, the value. 
786: ! 
787:   implicit none 
788:  
789:   real ( kind = 8 ) envj 
790:   real ( kind = 8 ) logten 
791:   integer ( kind = 4 ) n 
792:   real ( kind = 8 ) n_r8 
793:   real ( kind = 8 ) r8_gamma_log 
794:   real ( kind = 8 ) x 
795: ! 
796: !  Original code 
797: ! 
798: !  if ( .true. ) then 
799:  
800:     envj = 0.5D+00 * log10 ( 6.28D+00 * n ) & 
801:       - n * log10 ( 1.36D+00 * x / n ) 
802: ! 
803: !  Modification suggested by Vincent Lafage. 
804: ! 
805: !  else 
806:  
807: !    n_r8 = real ( n, kind = 8 ) 
808: !    logten = log ( 10.0D+00 ) 
809: !    envj = r8_gamma_log ( n_r8 + 1.0D+00 ) / logten - n_r8 * log10 ( x ) 
810:  
811: !  end if 
812:  
813:   return 
814: end 
815:  
816:  
817:  
818: function msta1 ( x, mp ) 
819:  
820: !*****************************************************************************80 
821: ! 
822: !! MSTA1 determines a backward recurrence starting point for Jn(x). 
823: ! 
824: !  Discussion: 
825: ! 
826: !    This procedure determines the starting point for backward 
827: !    recurrence such that the magnitude of 
828: !    Jn(x) at that point is about 10^(-MP). 
829: ! 
830: !  Licensing: 
831: ! 
832: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However, 
833: !    they give permission to incorporate this routine into a user program 
834: !    provided that the copyright is acknowledged. 
835: ! 
836: !  Modified: 
837: ! 
838: !    08 July 2012 
839: ! 
840: !  Author: 
841: ! 
842: !    Shanjie Zhang, Jianming Jin 
843: ! 
844: !  Reference: 
845: ! 
846: !    Shanjie Zhang, Jianming Jin, 
847: !    Computation of Special Functions, 
848: !    Wiley, 1996, 
849: !    ISBN: 0-471-11963-6, 
850: !    LC: QA351.C45. 
851: ! 
852: !  Parameters: 
853: ! 
854: !    Input, real ( kind = 8 ) X, the argument. 
855: ! 
856: !    Input, integer ( kind = 4 ) MP, the negative logarithm of the 
857: !    desired magnitude. 
858: ! 
859: !    Output, integer ( kind = 4 ) MSTA1, the starting point. 
860: ! 
861:   implicit none 
862:  
863:   real ( kind = 8 ) a0 
864:   real ( kind = 8 ) envj 
865:   real ( kind = 8 ) f 
866:   real ( kind = 8 ) f0 
867:   real ( kind = 8 ) f1 
868:   integer ( kind = 4 ) it 
869:   integer ( kind = 4 ) mp 
870:   integer ( kind = 4 ) msta1 
871:   integer ( kind = 4 ) n0 
872:   integer ( kind = 4 ) n1 
873:   integer ( kind = 4 ) nn 
874:   real ( kind = 8 ) x 
875:  
876:   a0 = abs ( x ) 
877:   n0 = int ( 1.1D+00 * a0 ) + 1 
878:   f0 = envj ( n0, a0 ) - mp 
879:   n1 = n0 + 5 
880:   f1 = envj ( n1, a0 ) - mp 
881:   do it = 1, 20 
882:     nn = n1 - ( n1 - n0 ) / ( 1.0D+00 - f0 / f1 ) 
883:     f = envj ( nn, a0 ) - mp 
884:     if ( abs ( nn - n1 ) < 1 ) then 
885:       exit 
886:     end if 
887:     n0 = n1 
888:     f0 = f1 
889:     n1 = nn 
890:     f1 = f 
891:   end do 
892:  
893:   msta1 = nn 
894:  
895:   return 
896: end function msta1 
897:  
898: function msta2 ( x, n, mp ) 
899:  
900: !*****************************************************************************80 
901: ! 
902: !! MSTA2 determines a backward recurrence starting point for Jn(x). 
903: ! 
904: !  Discussion: 
905: ! 
906: !    This procedure determines the starting point for a backward 
907: !    recurrence such that all Jn(x) has MP significant digits. 
908: ! 
909: !    Jianming Jin supplied a modification to this code on 12 January 2016. 
910: ! 
911: !  Licensing: 
912: ! 
913: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However, 
914: !    they give permission to incorporate this routine into a user program 
915: !    provided that the copyright is acknowledged. 
916: ! 
917: !  Modified: 
918: ! 
919: !    14 January 2016 
920: ! 
921: !  Author: 
922: ! 
923: !    Shanjie Zhang, Jianming Jin 
924: ! 
925: !  Reference: 
926: ! 
927: !    Shanjie Zhang, Jianming Jin, 
928: !    Computation of Special Functions, 
929: !    Wiley, 1996, 
930: !    ISBN: 0-471-11963-6, 
931: !    LC: QA351.C45. 
932: ! 
933: !  Parameters: 
934: ! 
935: !    Input, real ( kind = 8 ) X, the argument of Jn(x). 
936: ! 
937: !    Input, integer ( kind = 4 ) N, the order of Jn(x). 
938: ! 
939: !    Input, integer ( kind = 4 ) MP, the number of significant digits. 
940: ! 
941: !    Output, integer ( kind = 4 ) MSTA2, the starting point. 
942: ! 
943:   implicit none 
944:  
945:   real ( kind = 8 ) a0 
946:   real ( kind = 8 ) ejn 
947:   real ( kind = 8 ) envj 
948:   real ( kind = 8 ) f 
949:   real ( kind = 8 ) f0 
950:   real ( kind = 8 ) f1 
951:   real ( kind = 8 ) hmp 
952:   integer ( kind = 4 ) it 
953:   integer ( kind = 4 ) mp 
954:   integer ( kind = 4 ) msta2 
955:   integer ( kind = 4 ) n 
956:   integer ( kind = 4 ) n0 
957:   integer ( kind = 4 ) n1 
958:   integer ( kind = 4 ) nn 
959:   real ( kind = 8 ) obj 
960:   real ( kind = 8 ) x 
961:  
962:   a0 = abs ( x ) 
963:   hmp = 0.5D+00 * mp 
964:   ejn = envj ( n, a0 ) 
965:  
966:   if ( ejn <= hmp ) then 
967:     obj = mp 
968: ! 
969: !  Original code: 
970: ! 
971: !   n0 = int ( 1.1D+00 * a0 ) 
972: ! 
973: !  Updated code: 
974: ! 
975:     n0 = int ( 1.1D+00 * a0 ) + 1 
976:   else 
977:     obj = hmp + ejn 
978:     n0 = n 
979:   end if 
980:  
981:   f0 = envj ( n0, a0 ) - obj 
982:   n1 = n0 + 5 
983:   f1 = envj ( n1, a0 ) - obj 
984:  
985:   do it = 1, 20 
986:     nn = n1 - ( n1 - n0 ) / ( 1.0D+00 - f0 / f1 ) 
987:     f = envj ( nn, a0 ) - obj 
988:     if ( abs ( nn - n1 ) < 1 ) then 
989:       exit 
990:     end if 
991:     n0 = n1 
992:     f0 = f1 
993:     n1 = nn 
994:     f1 = f 
995:   end do 
996:  
997:   msta2 = nn + 10 
998:  
999:   return 
1000: end function msta2 
1001:  
1002: subroutine sphi ( n, x, nm, si) 
1003:  
1004: !*****************************************************************************80 
1005: ! 
1006: !! SPHI computes spherical Bessel functions in(x) and their derivatives in'(x). 
1007: ! 
1008: !  Licensing: 
1009: ! 
1010: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However, 
1011: !    they give permission to incorporate this routine into a user program 
1012: !    provided that the copyright is acknowledged. 
1013: ! 
1014: !  Modified: 
1015: ! 
1016: !    18 July 2012 
1017: ! 
1018: !  Author: 
1019: ! 
1020: !    Shanjie Zhang, Jianming Jin 
1021: ! 
1022: !  Reference: 
1023: ! 
1024: !    Shanjie Zhang, Jianming Jin, 
1025: !    Computation of Special Functions, 
1026: !    Wiley, 1996, 
1027: !    ISBN: 0-471-11963-6, 
1028: !    LC: QA351.C45. 
1029: ! 
1030: !  Parameters: 
1031: ! 
1032: !    Input, integer ( kind = 4 ) N, the order of In(X). 
1033: ! 
1034: !    Input, real ( kind = 8 ) X, the argument. 
1035: ! 
1036: !    Output, integer ( kind = 4 ) NM, the highest order computed. 
1037: ! 
1038: !    Output, real ( kind = 8 ) SI(0:N), DI(0:N), the values and derivatives 
1039: !    of the function of orders 0 through N. 
1040: ! 
1041:   implicit none 
1042:  
1043:   integer ( kind = 4 ), intent(in) :: n 
1044:  
1045:   real ( kind = 8 ) cs 
1046:   real ( kind = 8 ) f 
1047:   real ( kind = 8 ) f0 
1048:   real ( kind = 8 ) f1 
1049:   integer ( kind = 4 ) k 
1050:   integer ( kind = 4 ) m 
1051:   integer ( kind = 4 ) msta1 
1052:   integer ( kind = 4 ) msta2 
1053:   integer ( kind = 4 ), intent(out) :: nm 
1054:   real ( kind = 8 ), intent(out) :: si(0:n) 
1055:   real ( kind = 8 ) si0 
1056:   real ( kind = 8 ), intent(in) :: x 
1057:  
1058:   nm = n 
1059:  
1060:   if ( abs ( x ) < 1.0D-100 ) then 
1061:     do k = 0, n 
1062:       si(k) = 0.0D+00 
1063:     end do 
1064:     si(0) = 1.0D+00 
1065:     return 
1066:   end if 
1067:  
1068:   si(0) = sinh ( x ) / x 
1069:   si(1) = -( sinh ( x ) / x - cosh ( x ) ) / x 
1070:   si0 = si(0) 
1071:  
1072:   if ( 2 <= n ) then 
1073:  
1074:     m = msta1 ( x, 200 ) 
1075:     if ( m < n ) then 
1076:       nm = m 
1077:     else 
1078:       m = msta2 ( x, n, 15 ) 
1079:     end if 
1080:     f0 = 0.0D+00 
1081:     f1 = 1.0D+00-100 
1082:     do k = m, 0, -1 
1083:       f = ( 2.0D+00 * k + 3.0D+00 ) * f1 / x + f0 
1084:       if ( k <= nm ) then 
1085:         si(k) = f 
1086:       end if 
1087:       f0 = f1 
1088:       f1 = f 
1089:     end do 
1090:     cs = si0 / f 
1091:     do k = 0, nm 
1092:       si(k) = cs * si(k) 
1093:     end do 
1094:  
1095:   end if 
1096:  
1097:   return 
1098: end subroutine sphi 
1099:  
1100:  
1101: subroutine HYP1F1 ( ain, bin, xin, hg ) 
1102:  
1103: !*****************************************************************************80 
1104: ! 
1105: !! CHGM computes the confluent hypergeometric function M(a,b,x). 
1106: ! 
1107: !  Licensing: 
1108: ! 
1109: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However, 
1110: !    they give permission to incorporate this routine into a user program 
1111: !    provided that the copyright is acknowledged. 
1112: ! 
1113: !  Modified: 
1114: ! 
1115: !    27 July 2012 
1116: ! 
1117: !  Author: 
1118: ! 
1119: !    Shanjie Zhang, Jianming Jin 
1120: ! 
1121: !  Reference: 
1122: ! 
1123: !    Shanjie Zhang, Jianming Jin, 
1124: !    Computation of Special Functions, 
1125: !    Wiley, 1996, 
1126: !    ISBN: 0-471-11963-6, 
1127: !    LC: QA351.C45. 
1128: ! 
1129: !  Parameters: 
1130: ! 
1131: !    Input, real ( kind = 8 ) A, B, parameters. 
1132: ! 
1133: !    Input, real ( kind = 8 ) X, the argument. 
1134: ! 
1135: !    Output, real ( kind = 8 ) HG, the value of M(a,b,x). 
1136: ! 
1137:   implicit none 
1138:  
1139:   real ( kind = 8 ), intent(in) :: ain 
1140:   real ( kind = 8 ), intent(in) :: bin 
1141:   real ( kind = 8 ), intent(in) :: xin 
1142:   real ( kind = 8 ), intent(out) :: hg 
1143:  
1144:   real ( kind = 8 ) a 
1145:   real ( kind = 8 ) b 
1146:   real ( kind = 8 ) x 
1147:  
1148:   real ( kind = 8 ) a0 
1149:   real ( kind = 8 ) a1 
1150:   real ( kind = 8 ) aa 
1151:  
1152:   real ( kind = 8 ) hg1 
1153:   real ( kind = 8 ) hg2 
1154:   integer ( kind = 4 ) i 
1155:   integer ( kind = 4 ) j 
1156:   integer ( kind = 4 ) k 
1157:   integer ( kind = 4 ) la 
1158:   integer ( kind = 4 ) m 
1159:   integer ( kind = 4 ) n 
1160:   integer ( kind = 4 ) nl 
1161:   real ( kind = 8 ) pi 
1162:   real ( kind = 8 ) r 
1163:   real ( kind = 8 ) r1 
1164:   real ( kind = 8 ) r2 
1165:   real ( kind = 8 ) rg 
1166:   real ( kind = 8 ) sum1 
1167:   real ( kind = 8 ) sum2 
1168:   real ( kind = 8 ) ta 
1169:   real ( kind = 8 ) tb 
1170:   real ( kind = 8 ) tba 
1171:   real ( kind = 8 ) x0 
1172:   real ( kind = 8 ) xg 
1173:   real ( kind = 8 ) y0 
1174:   real ( kind = 8 ) y1 
1175:  
1176:   a=ain 
1177:   b=bin 
1178:   x=xin 
1179:   pi = 3.141592653589793D+00 
1180:   a0 = a 
1181:   a1 = a 
1182:   x0 = x 
1183:   hg = 0.0D+00 
1184:  
1185:   y1 = hg 
1186:  
1187:   if ( b == 0.0D+00 .or. b == - abs ( int ( b ) ) ) then 
1188:     hg = 1.0D+300 
1189:   else if ( a == 0.0D+00 .or. x == 0.0D+00 ) then 
1190:     hg = 1.0D+00 
1191:   else if ( a == -1.0D+00 ) then 
1192:     hg = 1.0D+00 - x / b 
1193:   else if ( a == b ) then 
1194:     hg = exp ( x ) 
1195:   else if ( a - b == 1.0D+00 ) then 
1196:     hg = ( 1.0D+00 + x / b ) * exp ( x ) 
1197:   else if ( a == 1.0D+00 .and. b == 2.0D+00 ) then 
1198:     hg = ( exp ( x ) - 1.0D+00 ) / x 
1199:   else if ( a == int ( a ) .and. a < 0.0D+00 ) then 
1200:     m = int ( - a ) 
1201:     r = 1.0D+00 
1202:     hg = 1.0D+00 
1203:     do k = 1, m 
1204:       r = r * ( a + k - 1.0D+00 ) / k / ( b + k - 1.0D+00 ) * x 
1205:       hg = hg + r 
1206:     end do 
1207:   end if 
1208:  
1209:   if ( hg /= 0.0D+00 ) then 
1210:     return 
1211:   end if 
1212:  
1213:   if ( x < 0.0D+00 ) then 
1214:     a = b - a 
1215:     a0 = a 
1216:     x = abs ( x ) 
1217:   end if 
1218:  
1219:   if ( a < 2.0D+00 ) then 
1220:     nl = 0 
1221:   end if 
1222:  
1223:   if ( 2.0D+00 <= a ) then 
1224:     nl = 1 
1225:     la = int ( a ) 
1226:     a = a - la - 1.0D+00 
1227:   end if 
1228:  
1229:   do n = 0, nl 
1230:  
1231:     if ( 2.0D+00 <= a0 ) then 
1232:       a = a + 1.0D+00 
1233:     end if 
1234:  
1235:     if ( x <= 30.0D+00 + abs ( b ) .or. a < 0.0D+00 ) then 
1236:  
1237:       hg = 1.0D+00 
1238:       rg = 1.0D+00 
1239:       do j = 1, 500 
1240:         rg = rg * ( a + j - 1.0D+00 ) & 
1241:           / ( j * ( b + j - 1.0D+00 ) ) * x 
1242:         hg = hg + rg 
1243:         if ( abs ( rg / hg ) < 1.0D-15 ) then 
1244:           exit 
1245:         end if 
1246:       end do 
1247:  
1248:     else 
1249:  
1250:       call gamma ( a, ta ) 
1251:       call gamma ( b, tb ) 
1252:       xg = b - a 
1253:       call gamma ( xg, tba ) 
1254:       sum1 = 1.0D+00 
1255:       sum2 = 1.0D+00 
1256:       r1 = 1.0D+00 
1257:       r2 = 1.0D+00 
1258:       do i = 1, 8 
1259:         r1 = - r1 * ( a + i - 1.0D+00 ) * ( a - b + i ) / ( x * i ) 
1260:         r2 = - r2 * ( b - a + i - 1.0D+00 ) * ( a - i ) / ( x * i ) 
1261:         sum1 = sum1 + r1 
1262:         sum2 = sum2 + r2 
1263:       end do 
1264:       hg1 = tb / tba * x ** ( - a ) * cos ( pi * a ) * sum1 
1265:       hg2 = tb / ta * exp ( x ) * x ** ( a - b ) * sum2 
1266:       hg = hg1 + hg2 
1267:  
1268:     end if 
1269:  
1270:     if ( n == 0 ) then 
1271:       y0 = hg 
1272:     else if ( n == 1 ) then 
1273:       y1 = hg 
1274:     end if 
1275:  
1276:   end do 
1277:  
1278:   if ( 2.0D+00 <= a0 ) then 
1279:     do i = 1, la - 1 
1280:       hg = ( ( 2.0D+00 * a - b + x ) * y1 + ( b - a ) * y0 ) / a 
1281:       y0 = y1 
1282:       y1 = hg 
1283:       a = a + 1.0D+00 
1284:     end do 
1285:   end if 
1286:  
1287:   if ( x0 < 0.0D+00 ) then 
1288:     hg = hg * exp ( x0 ) 
1289:   end if 
1290:  
1291:   a = a1 
1292:   x = x0 
1293:  
1294:   return 
1295: end 
1296:  
1297: subroutine gamma ( x, ga ) 
1298:  
1299: !*****************************************************************************80 
1300: ! 
1301: !! GAMMA evaluates the Gamma function. 
1302: ! 
1303: !  Licensing: 
1304: ! 
1305: !    The original FORTRAN77 version of this routine is copyrighted by 
1306: !    Shanjie Zhang and Jianming Jin.  However, they give permission to 
1307: !    incorporate this routine into a user program that the copyright 
1308: !    is acknowledged. 
1309: ! 
1310: !  Modified: 
1311: ! 
1312: !    08 September 2007 
1313: ! 
1314: !  Author: 
1315: ! 
1316: !    Original FORTRAN77 version by Shanjie Zhang, Jianming Jin. 
1317: !    FORTRAN90 version by John Burkardt. 
1318: ! 
1319: !  Reference: 
1320: ! 
1321: !    Shanjie Zhang, Jianming Jin, 
1322: !    Computation of Special Functions, 
1323: !    Wiley, 1996, 
1324: !    ISBN: 0-471-11963-6, 
1325: !    LC: QA351.C45 
1326: ! 
1327: !  Parameters: 
1328: ! 
1329: !    Input, real ( kind = 8 ) X, the argument. 
1330: !    X must not be 0, or any negative integer. 
1331: ! 
1332: !    Output, real ( kind = 8 ) GA, the value of the Gamma function. 
1333: ! 
1334:   implicit none 
1335:  
1336:   real ( kind = 8 ), intent(in) :: x 
1337:   real ( kind = 8 ), intent(out) :: ga 
1338:  
1339:   real ( kind = 8 ), dimension ( 26 ) :: g = (/ & 
1340:     1.0D+00, & 
1341:     0.5772156649015329D+00, & 
1342:    -0.6558780715202538D+00, & 
1343:    -0.420026350340952D-01, & 
1344:     0.1665386113822915D+00, & 
1345:    -0.421977345555443D-01, & 
1346:    -0.96219715278770D-02, & 
1347:     0.72189432466630D-02, & 
1348:    -0.11651675918591D-02, & 
1349:    -0.2152416741149D-03, & 
1350:     0.1280502823882D-03, & 
1351:    -0.201348547807D-04, & 
1352:    -0.12504934821D-05, & 
1353:     0.11330272320D-05, & 
1354:    -0.2056338417D-06, & 
1355:     0.61160950D-08, & 
1356:     0.50020075D-08, & 
1357:    -0.11812746D-08, & 
1358:     0.1043427D-09, & 
1359:     0.77823D-11, & 
1360:    -0.36968D-11, & 
1361:     0.51D-12, & 
1362:    -0.206D-13, & 
1363:    -0.54D-14, & 
1364:     0.14D-14, & 
1365:     0.1D-15 /) 
1366:  
1367:   real ( kind = 8 ) gr 
1368:   integer ( kind = 4 ) k 
1369:   integer ( kind = 4 ) m 
1370:   integer ( kind = 4 ) m1 
1371:   real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 
1372:   real ( kind = 8 ) r 
1373:   real ( kind = 8 ) z 
1374:  
1375:   if ( x == aint ( x ) ) then 
1376:  
1377:     if ( 0.0D+00 < x ) then 
1378:       ga = 1.0D+00 
1379:       m1 = int ( x ) - 1 
1380:       do k = 2, m1 
1381:         ga = ga * k 
1382:       end do 
1383:     else 
1384:       ga = 1.0D+300 
1385:     end if 
1386:  
1387:   else 
1388:  
1389:     if ( 1.0D+00 < abs ( x ) ) then 
1390:       z = abs ( x ) 
1391:       m = int ( z ) 
1392:       r = 1.0D+00 
1393:       do k = 1, m 
1394:         r = r * ( z - real ( k, kind = 8 ) ) 
1395:       end do 
1396:       z = z - real ( m, kind = 8 ) 
1397:     else 
1398:       z = x 
1399:     end if 
1400:  
1401:     gr = g(26) 
1402:     do k = 25, 1, -1 
1403:       gr = gr * z + g(k) 
1404:     end do 
1405:  
1406:     ga = 1.0D+00 / ( gr * z ) 
1407:  
1408:     if ( 1.0D+00 < abs ( x ) ) then 
1409:       ga = ga * r 
1410:       if ( x < 0.0D+00 ) then 
1411:         ga = - pi / ( x* ga * sin ( pi * x ) ) 
1412:       end if 
1413:     end if 
1414:  
1415:   end if 
1416:  
1417:   return 
1418: end 
1419:  
1420:  
1421:  
1422: !    CODE REPRODUCED FROM MINPACK UNDER THE GNU LPGL LICENCE: 
1423:  
1424: !    REFERENCES: 
1425:  
1426: !    Jorge More, Burton Garbow, Kenneth Hillstrom, 
1427: !    User Guide for MINPACK-1, 
1428: !    Technical Report ANL-80-74, 
1429: !    Argonne National Laboratory, 1980. 
1430:  
1431: !    Jorge More, Danny Sorenson, Burton Garbow, Kenneth Hillstrom, 
1432: !    The MINPACK Project, 
1433: !    in Sources and Development of Mathematical Software, 
1434: !    edited by Wayne Cowell, 
1435: !    Prentice-Hall, 1984, 
1436: !    ISBN: 0-13-823501-5, 
1437: !    LC: QA76.95.S68. 
1438:  
1439:  
1440:  
1441: subroutine lmder ( fcn, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, maxfev, & 
1442:   diag, mode, factor, nprint, info, nfev, njev, ipvt, qtf ) 
1443:  
1444: !*****************************************************************************80 
1445: ! 
1446: !! LMDER minimizes M functions in N variables by the Levenberg-Marquardt method. 
1447: ! 
1448: !  Discussion: 
1449: ! 
1450: !    LMDER minimizes the sum of the squares of M nonlinear functions in 
1451: !    N variables by a modification of the Levenberg-Marquardt algorithm. 
1452: !    The user must provide a subroutine which calculates the functions 
1453: !    and the jacobian. 
1454: ! 
1455: !  Licensing: 
1456: ! 
1457: !    This code is distributed under the GNU LGPL license. 
1458: ! 
1459: !  Modified: 
1460: ! 
1461: !    06 April 2010 
1462: ! 
1463: !  Author: 
1464: ! 
1465: !    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom. 
1466: !    FORTRAN90 version by John Burkardt. 
1467: ! 
1468: !  Reference: 
1469: ! 
1470: !    Jorge More, Burton Garbow, Kenneth Hillstrom, 
1471: !    User Guide for MINPACK-1, 
1472: !    Technical Report ANL-80-74, 
1473: !    Argonne National Laboratory, 1980. 
1474: ! 
1475: !  Parameters: 
1476: ! 
1477: !    Input, external FCN, the name of the user-supplied subroutine which 
1478: !    calculates the functions and the jacobian.  FCN should have the form: 
1479: !      subroutine fcn ( m, n, x, fvec, fjac, ldfjac, iflag ) 
1480: !      integer ( kind = 4 ) ldfjac 
1481: !      integer ( kind = 4 ) n 
1482: !      real ( kind = 8 ) fjac(ldfjac,n) 
1483: !      real ( kind = 8 ) fvec(m) 
1484: !      integer ( kind = 4 ) iflag 
1485: !      real ( kind = 8 ) x(n) 
1486: ! 
1487: !    If IFLAG = 0 on input, then FCN is only being called to allow the user 
1488: !    to print out the current iterate. 
1489: !    If IFLAG = 1 on input, FCN should calculate the functions at X and 
1490: !    return this vector in FVEC. 
1491: !    If IFLAG = 2 on input, FCN should calculate the jacobian at X and 
1492: !    return this matrix in FJAC. 
1493: !    To terminate the algorithm, FCN may set IFLAG negative on return. 
1494: ! 
1495: !    Input, integer ( kind = 4 ) M, is the number of functions. 
1496: ! 
1497: !    Input, integer ( kind = 4 ) N, is the number of variables. 
1498: !    N must not exceed M. 
1499: ! 
1500: !    Input/output, real ( kind = 8 ) X(N).  On input, X must contain an initial 
1501: !    estimate of the solution vector.  On output X contains the final 
1502: !    estimate of the solution vector. 
1503: ! 
1504: !    Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X. 
1505: ! 
1506: !    Output, real ( kind = 8 ) FJAC(LDFJAC,N), an M by N array.  The upper 
1507: !    N by N submatrix of FJAC contains an upper triangular matrix R with 
1508: !    diagonal elements of nonincreasing magnitude such that 
1509: !      P' * ( JAC' * JAC ) * P = R' * R, 
1510: !    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 lower 
1512: !    trapezoidal part of FJAC contains information generated during 
1513: !    the computation of R. 
1514: ! 
1515: !    Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC. 
1516: !    LDFJAC must be at least M. 
1517: ! 
1518: !    Input, real ( kind = 8 ) FTOL.  Termination occurs when both the actual 
1519: !    and predicted relative reductions in the sum of squares are at most FTOL. 
1520: !    Therefore, FTOL measures the relative error desired in the sum of 
1521: !    squares.  FTOL should be nonnegative. 
1522: ! 
1523: !    Input, real ( kind = 8 ) XTOL.  Termination occurs when the relative error 
1524: !    between two consecutive iterates is at most XTOL.  XTOL should be 
1525: !    nonnegative. 
1526: ! 
1527: !    Input, real ( kind = 8 ) GTOL.  Termination occurs when the cosine of the 
1528: !    angle between FVEC and any column of the jacobian is at most GTOL in 
1529: !    absolute value.  Therefore, GTOL measures the orthogonality desired 
1530: !    between the function vector and the columns of the jacobian.  GTOL should 
1531: !    be nonnegative. 
1532: ! 
1533: !    Input, integer ( kind = 4 ) MAXFEV.  Termination occurs when the number of 
1534: !    calls to FCN with IFLAG = 1 is at least MAXFEV by the end of an iteration. 
1535: ! 
1536: !    Input/output, real ( kind = 8 ) DIAG(N).  If MODE = 1, then DIAG is set 
1537: !    internally.  If MODE = 2, then DIAG must contain positive entries that 
1538: !    serve as multiplicative scale factors for the variables. 
1539: ! 
1540: !    Input, integer ( kind = 4 ) MODE, scaling option. 
1541: !    1, variables will be scaled internally. 
1542: !    2, scaling is specified by the input DIAG vector. 
1543: ! 
1544: !    Input, real ( kind = 8 ) FACTOR, determines the initial step bound.  This 
1545: !    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 lie 
1547: !    in the interval (0.1, 100) with 100 the recommended value. 
1548: ! 
1549: !    Input, integer ( kind = 4 ) NPRINT, enables controlled printing of iterates 
1550: !    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 thereafter 
1552: !    and immediately prior to return, with X and FVEC available 
1553: !    for printing.  If NPRINT is not positive, no special calls 
1554: !    of FCN with IFLAG = 0 are made. 
1555: ! 
1556: !    Output, integer ( kind = 4 ) INFO, error flag.  If the user has terminated 
1557: !    execution, INFO is set to the (negative) value of IFLAG. See description 
1558: !    of FCN.  Otherwise, INFO is set as follows: 
1559: !    0, improper input parameters. 
1560: !    1, both actual and predicted relative reductions in the sum of 
1561: !       squares are at most FTOL. 
1562: !    2, relative error between two consecutive iterates is at most XTOL. 
1563: !    3, conditions for INFO = 1 and INFO = 2 both hold. 
1564: !    4, the cosine of the angle between FVEC and any column of the jacobian 
1565: !       is at most GTOL in absolute value. 
1566: !    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 squares 
1568: !       is possible. 
1569: !    7, XTOL is too small.  No further improvement in the approximate 
1570: !       solution X is possible. 
1571: !    8, GTOL is too small.  FVEC is orthogonal to the columns of the 
1572: !       jacobian to machine precision. 
1573: ! 
1574: !    Output, integer ( kind = 4 ) NFEV, the number of calls to FCN with 
1575: !    IFLAG = 1. 
1576: ! 
1577: !    Output, integer ( kind = 4 ) NJEV, the number of calls to FCN with 
1578: !    IFLAG = 2. 
1579: ! 
1580: !    Output, integer ( kind = 4 ) IPVT(N), defines a permutation matrix P 
1581: !    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 diagonal 
1583: !    elements of nonincreasing magnitude.  Column J of P is column 
1584: !    IPVT(J) of the identity matrix. 
1585: ! 
1586: !    Output, real ( kind = 8 ) QTF(N), contains the first N elements of Q'*FVEC. 
1587: ! 
1588:   implicit none 
1589:  
1590:   integer ( kind = 4 ), INTENT(IN) :: ldfjac 
1591:   integer ( kind = 4 ), INTENT(IN) ::  m 
1592:   integer ( kind = 4 ), INTENT(IN) ::  n 
1593:  
1594:   real ( kind = 8 ) actred 
1595:   real ( kind = 8 ) delta 
1596:   real ( kind = 8 ), INTENT(INOUT) :: diag(n) 
1597:   real ( kind = 8 ) dirder 
1598:   real ( kind = 8 ) enorm 
1599:   real ( kind = 8 ) epsmch 
1600:   real ( kind = 8 ), INTENT(IN) :: factor 
1601:   external  fcn 
1602:   real ( kind = 8 ), INTENT(OUT) :: fjac(ldfjac,n) 
1603:   real ( kind = 8 ) fnorm 
1604:   real ( kind = 8 ) fnorm1 
1605:   real ( kind = 8 ), INTENT(IN) :: ftol 
1606:   real ( kind = 8 ), INTENT(OUT) :: fvec(m) 
1607:   real ( kind = 8 ) gnorm 
1608:   real ( kind = 8 ), INTENT(IN) :: gtol 
1609:   integer ( kind = 4 ) i 
1610:   integer ( kind = 4 ) iflag 
1611:   integer ( kind = 4 ), INTENT(OUT) :: info 
1612:   integer ( kind = 4 ) ipvt(n) 
1613:   integer ( kind = 4 ) iter 
1614:   integer ( kind = 4 ) j 
1615:   integer ( kind = 4 ) l 
1616:   integer ( kind = 4 ), INTENT(IN) :: maxfev 
1617:   integer ( kind = 4 ), INTENT(IN) :: mode 
1618:   integer ( kind = 4 ), INTENT(OUT) :: nfev 
1619:   integer ( kind = 4 ), INTENT(OUT) :: njev 
1620:   integer ( kind = 4 ), INTENT(IN) :: nprint 
1621:   real ( kind = 8 ) par 
1622:   logical pivot 
1623:   real ( kind = 8 ) pnorm 
1624:   real ( kind = 8 ) prered 
1625:   real ( kind = 8 ), INTENT(OUT) :: qtf(n) 
1626:   real ( kind = 8 ) ratio 
1627:   real ( kind = 8 ) sum2 
1628:   real ( kind = 8 ) temp 
1629:   real ( kind = 8 ) temp1 
1630:   real ( kind = 8 ) temp2 
1631:   real ( kind = 8 ) wa1(n) 
1632:   real ( kind = 8 ) wa2(n) 
1633:   real ( kind = 8 ) wa3(n) 
1634:   real ( kind = 8 ) wa4(m) 
1635:   real ( kind = 8 ) xnorm 
1636:   real ( kind = 8 ), INTENT(INOUT) ::  x(n) 
1637:   real ( kind = 8 ), INTENT(IN) :: xtol 
1638:  
1639:   epsmch = epsilon ( epsmch ) 
1640:  
1641:   info = 0 
1642:   iflag = 0 
1643:   nfev = 0 
1644:   njev = 0 
1645: ! 
1646: !  Check the input parameters for errors. 
1647: ! 
1648:   if ( n <= 0 ) then 
1649:     go to 300 
1650:   end if 
1651:  
1652:   if ( m < n ) then 
1653:     go to 300 
1654:   end if 
1655:  
1656:   if ( ldfjac < m & 
1657:     .or. ftol < 0.0D+00 .or. xtol < 0.0D+00 .or. gtol < 0.0D+00 & 
1658:      .or. maxfev <= 0 .or. factor <= 0.0D+00 ) then 
1659:     go to 300 
1660:   end if 
1661:  
1662:   if ( mode == 2 ) then 
1663:     do j = 1, n 
1664:       if ( diag(j) <= 0.0D+00 ) then 
1665:         go to 300 
1666:       end if 
1667:     end do 
1668:   end if 
1669: ! 
1670: !  Evaluate the function at the starting point and calculate its norm. 
1671: ! 
1672:   iflag = 1 
1673:   call fcn ( m, n, x, fvec, fjac, ldfjac, iflag ) 
1674:   nfev = 1 
1675:   if ( iflag < 0 ) then 
1676:     go to 300 
1677:   end if 
1678:  
1679:   fnorm = enorm ( m, fvec ) 
1680: ! 
1681: !  Initialize Levenberg-Marquardt parameter and iteration counter. 
1682: ! 
1683:   par = 0.0D+00 
1684:   iter = 1 
1685: ! 
1686: !  Beginning of the outer loop. 
1687: ! 
1688: 30   continue 
1689: ! 
1690: !  Calculate the jacobian matrix. 
1691: ! 
1692:     iflag = 2 
1693:     call fcn ( m, n, x, fvec, fjac, ldfjac, iflag ) 
1694:  
1695:     njev = njev + 1 
1696:  
1697:     if ( iflag < 0 ) then 
1698:       go to 300 
1699:     end if 
1700: ! 
1701: !  If requested, call FCN to enable printing of iterates. 
1702: ! 
1703:     if ( 0 < nprint ) then 
1704:       iflag = 0 
1705:       if ( mod ( iter - 1, nprint ) == 0 ) then 
1706:         call fcn ( m, n, x, fvec, fjac, ldfjac, iflag ) 
1707:       end if 
1708:       if ( iflag < 0 ) then 
1709:         go to 300 
1710:       end if 
1711:     end if 
1712: ! 
1713: !  Compute the QR factorization of the jacobian. 
1714: ! 
1715:     pivot = .true. 
1716:     call qrfac ( m, n, fjac, ldfjac, pivot, ipvt, n, wa1, wa2 ) 
1717: ! 
1718: !  On the first iteration and if mode is 1, scale according 
17