hdiff output

r33305/ALIGN 2017-09-13 18:30:16.630026786 +0100 r33304/ALIGN 2017-09-13 18:30:19.890070115 +0100
  1: svn: warning: W195007: URL 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/GMIN/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/GMIN/source/ALIGN' in revision 33304
  2: svn: E200009: Could not cat all targets because some targets are directories 
  3: svn: E200009: Illegal target for the requested operation 


r33305/align_decide.f90 2017-09-13 18:30:17.238034867 +0100 r33304/align_decide.f90 2017-09-13 18:30:20.546078834 +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/GMIN/source/ALIGN/align_decide.f90' in revision 33304
  2:  
  3: USE COMMONS, 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:                    MYUNIT, BOXLX, BOXLY, BOXLZ, & ! Misc variables from the main program 
  8:                    NSETS, PERMOPT, PERMINVOPT, 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, SAVEPERMOPT, SAVEPERMINVOPT 
 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. ((ABS(NBOXLX-BOXLX).GT.1.0D-8) .OR. (ABS(NBOXLX-BOXLX).GT.1.0D-8) .OR. (ABS(NBOXLX-BOXLX).GT.1.0D-8))) THEN 
 25:    WRITE(MYUNIT,*) "align_decide> ERROR: Box parameters passed in as arguments differ to those USEd from COMMONS." 
 26:    WRITE(MYUNIT,*) "Passed in: ", NBOXLX,NBOXLY,NBOXLZ 
 27:    WRITE(MYUNIT,*) "USEd: ", BOXLX, BOXLY, BOXLZ 
 28:    STOP 1 
 29: ENDIF   
 30:  
 31: IF (FASTOVERLAPT .OR. BNB_ALIGNT) THEN 
 32:    IF ((RIGIDINIT .AND. (.NOT.ATOMRIGIDCOORDT)) .OR. RIGID) THEN 
 33:       WRITE(MYUNIT,*) "align_decide> fastoverlap and BNB methods do not work in rigid body coordinates. Use cartesians instead." 
 34:       STOP 
 35:    ELSEIF (ANY(NSETS(:).GT.0)) THEN 
 36:       WRITE(MYUNIT,*) "align_decide> fastoverlap and BNB methods is not tested for secondary permutable sets, and probably doesn't work. Stopping now." 
 37:       STOP 
 38:    ENDIF 
 39:  
 40:    ! In order to ensure that the correct logic is followed in MINPERMDIST, we need to make sure that PERMOPT and PERMINVOPT 
 41:    ! have the correct values for the system type. Unfortunately, we need PERMOPT set for clusters even if it's not being used 
 42:    ! for the rest of the program. 
 43:    SAVEPERMOPT = PERMOPT; SAVEPERMINVOPT = PERMINVOPT 
 44:    IF(BULKT) THEN 
 45:       PERMOPT = .FALSE. 
 46:       PERMINVOPT = .FALSE. 
 47:    ELSE 
 48:       PERMOPT = .TRUE. 
 49:       IF(.NOT.NOINVERSION) PERMINVOPT=.TRUE.  ! Inversion isomers will be identified unless you have NOINVERSION set! 
 50:    ENDIF 
 51:  
 52: ENDIF 
 53:  
 54: ! Now perform the actual alignment call. 
 55:  
 56: IF (FASTOVERLAPT) THEN 
 57:     
 58:    IF(BULKT) THEN 
 59:       IF (DEBUG) WRITE(MYUNIT,*) "align_decide> using fastoverlap periodic alignment" 
 60:       CALL FOM_ALIGN_BULK(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,KERNELWIDTH,NDISPLACEMENTS,DISTANCE,DIST2) 
 61:    ELSE 
 62:       IF (DEBUG) WRITE(MYUNIT,*) "align_decide> using fastoverlap cluster alignment" 
 63:       CALL FOM_ALIGN_CLUSTERS(COORDSB,COORDSA,NATOMS,DEBUG,MAX_ANGMOM,KERNELWIDTH,DISTANCE,DIST2,RMATBEST,NROTATIONS) 
 64:    ENDIF 
 65:  
 66: ELSE IF (BNB_ALIGNT) THEN 
 67:  
 68:    IF(DEBUG) WRITE(MYUNIT,*) "align_decide> using BNB align" 
 69:    CALL BNB_ALIGN(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,BULKT,DISTANCE,DIST2,RMATBEST,BNB_NSTEPS) 
 70:  
 71: ELSE 
 72:    IF(DEBUG) WRITE(MYUNIT,*) "align_decide> using original MINPERMDIST routine" 
 73:    CALL MINPERMDIST(COORDSB,COORDSA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,BULKT,TWOD,DISTANCE,DIST2,RIGID,RMATBEST) 
 74:  
 75: ENDIF 
 76:  
 77: IF (FASTOVERLAPT .OR. BNB_ALIGNT) THEN 
 78:    PERMOPT = SAVEPERMOPT; PERMINVOPT = SAVEPERMINVOPT 
 79: ENDIF 
 80:  
 81: END SUBROUTINE 


r33305/bnbalign.f90 2017-09-13 18:30:17.458037795 +0100 r33304/bnbalign.f90 2017-09-13 18:30:20.762081706 +0100
  1: !INCLUDE "commons.f90"  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/GMIN/source/ALIGN/bnbalign.f90' in revision 33304
  2:  
  3: MODULE GOPERMDIST 
  4:  
  5: ! SAVECOORDSA(3*NATOMS,NSTRUCTS) stores the centred candidate structures 
  6: ! SAVECOORDSB(3*NATOMS) stores the centred target structure 
  7:  
  8: ! PERMCOORDSB(3,NATOMS,NPERMGROUP) stores the structures for the k-d tree 
  9:  
 10:  
 11: USE COMMONS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP, BESTPERM, MYUNIT, & 
 12:  & NSETS, SETS, OHCELLT, PERMINVOPT, PERMDIST, PERMOPT, BOXLX, BOXLY, BOXLZ 
 13: USE PRIORITYQUEUE, ONLY: QUEUE 
 14:  
 15: IMPLICIT NONE 
 16:  
 17: INTEGER, SAVE :: NATOMS, NCALC, NLAP, NQUENCH, NBAD 
 18: INTEGER, SAVE :: PMAXNEI = 60 ! Number of nearest neighbours to store 
 19: DOUBLE PRECISION, PARAMETER :: PSCALE = 1.D6 ! Scale for linear assignment problem 
 20: DOUBLE PRECISION, PARAMETER :: PI = 3.141592653589793D0 
 21: ! Absolute Tolerance, Relative Tolerance, Relative Tolerance for MINPERMDIST quench 
 22: DOUBLE PRECISION, SAVE :: ATOL=1D-8, RTOL=1D-1, MPRTOL=1.D-1 
 23: LOGICAL, SAVE :: DEBUG = .TRUE. 
 24:  
 25:  
 26: DOUBLE PRECISION, SAVE :: LVECS(3,0:8), FVECS(4,6) 
 27:  
 28: DOUBLE PRECISION, SAVE :: CMAX,CMAY,CMAZ,CMBX,CMBY,CMBZ 
 29: DOUBLE PRECISION, SAVE :: DUMMYRMAT(3,3), TRMAT(3,3) 
 30: LOGICAL, SAVE :: PERMINVOPTSAVE, NOINVERSIONSAVE 
 31:  
 32: ! Module saves periodic conditions variables 
 33: LOGICAL, SAVE :: BULKT 
 34: LOGICAL, SAVE :: OHCELLTSAVE 
 35: DOUBLE PRECISION, SAVE :: BOXVEC(3) 
 36:  
 37: ! Arrays to store target and candidate structures and best found structures 
 38: DOUBLE PRECISION, SAVE, ALLOCATABLE  :: SAVECOORDSA(:,:),PERMCOORDSB(:,:,:), & 
 39:  & SAVECOORDSB(:), BESTCOORDSA(:,:), BESTRMAT(:,:,:) 
 40: DOUBLE PRECISION, SAVE, ALLOCATABLE  :: SAVERA(:,:), SAVERB(:) 
 41: INTEGER, SAVE, ALLOCATABLE :: BESTITERS(:) 
 42: INTEGER, SAVE :: BESTID, BESTITER 
 43:  
 44:  
 45: ! Used when calculating Boundsin CALCBOUNDS 
 46: DOUBLE PRECISION :: BRANCHVECS(3,8) 
 47: DOUBLE PRECISION, SAVE, ALLOCATABLE  :: DUMMYCOORDSA(:,:), PDUMMYND(:) 
 48: ! Arrays of distances and nearest neighbour distances 
 49: DOUBLE PRECISION, SAVE, ALLOCATABLE :: DUMMYDISTS(:,:), DUMMYNEARDISTS(:) 
 50: DOUBLE PRECISION, SAVE, ALLOCATABLE :: DUMMYDISPS(:,:,:) 
 51: ! Arrays of bounded distances and nearest neighbour distances 
 52: DOUBLE PRECISION, SAVE, ALLOCATABLE :: DUMMYLDISTS(:,:), DUMMYNEARLDISTS(:), & 
 53:  & DUMMYLDISTS2(:,:), DUMMYDOTDISP(:,:,:) 
 54:  
 55: INTEGER, SAVE, ALLOCATABLE :: DUMMYIDX(:,:), DINVIDX(:,:), DUMMYNEARIDX(:) 
 56: INTEGER, SAVE, ALLOCATABLE :: INVPERMGROUP(:) 
 57:  
 58: ! Used when solving assignment problem 
 59: DOUBLE PRECISION, SAVE, ALLOCATABLE :: PDUMMYA(:), PDUMMYB(:), DUMMYA(:), & 
 60:     & DUMMYB(:), XBESTA(:), XBESTASAVE(:) 
 61: INTEGER, SAVE, ALLOCATABLE :: NEWPERM(:), LPERM(:) 
 62:  
 63: !TYPE(KDTREE2PTR), ALLOCATABLE :: KDTREES(:) 
 64: TYPE(QUEUE) :: Q 
 65:  
 66: DATA LVECS / & 
 67:  & 0.0D0, 0.0D0, 0.0D0, & 
 68:  & 1.0D0, 1.0D0, 1.0D0, & 
 69:  & 1.0D0, 1.0D0, -1.0D0, & 
 70:  & 1.0D0, -1.0D0, 1.0D0, & 
 71:  & 1.0D0, -1.0D0, -1.0D0, & 
 72:  & -1.0D0, 1.0D0, 1.0D0, & 
 73:  & -1.0D0, 1.0D0, -1.0D0, & 
 74:  & -1.0D0, -1.0D0, 1.0D0, & 
 75:  & -1.0D0, -1.0D0, -1.0D0 / 
 76:  
 77: DATA FVECS / & 
 78:  &  1.0D0,  1.0D0,  1.0D0,  1.0D0, & 
 79:  &  1.0D0,  1.0D0, -1.0D0, -1.0D0, & 
 80:  &  1.0D0, -1.0D0,  1.0D0, -1.0D0, & 
 81:  & -1.0D0, -1.0D0, -1.0D0, -1.0D0, & 
 82:  & -1.0D0, -1.0D0,  1.0D0,  1.0D0, & 
 83:  & -1.0D0,  1.0D0, -1.0D0,  1.0D0 / 
 84:  
 85: ! Private so that module works with f2py and static linking to kdtree2.f90 and 
 86: ! priorityqueue.f90 
 87: PRIVATE :: Q!, KDTREES 
 88:  
 89: CONTAINS 
 90:  
 91: SUBROUTINE BNB_ALIGN(COORDSB,COORDSA,LNATOMS,DEBUGT,NBOXLX,NBOXLY,NBOXLZ,NBULKT, & 
 92:     & DISTANCE,DIST2,RMATBEST,NSTEPS) 
 93:  
 94: IMPLICIT NONE 
 95:  
 96: LOGICAL, INTENT(IN) :: NBULKT, DEBUGT 
 97: INTEGER, INTENT(IN) :: LNATOMS, NSTEPS 
 98: DOUBLE PRECISION, INTENT(INOUT) :: COORDSB(3*LNATOMS), COORDSA(3*LNATOMS) 
 99: DOUBLE PRECISION, INTENT(IN) :: NBOXLX, NBOXLY, NBOXLZ 
100:  
101: DOUBLE PRECISION, INTENT(OUT) :: DISTANCE, DIST2, RMATBEST(3,3) 
102:  
103: DOUBLE PRECISION VECTOR(3), WIDTH, BESTUPPER, LOWERBOUND, UPPERBOUND 
104: INTEGER IDNUM 
105:  
106:  
107: ! Allocating and assigning to temporary arrays 
108: CALL SETNATOMS(LNATOMS) 
109: CALL INITIALISE(COORDSB, COORDSA, NATOMS, NBOXLX, NBOXLY, NBOXLZ, NBULKT) 
110:  
111: ! Setting parameters 
112: DEBUG = DEBUGT 
113: BESTUPPER = HUGE(1.D0) 
114: VECTOR(:) = 0.D0 
115: IF(BULKT) THEN 
116:     WIDTH = MAX(NBOXLX, NBOXLY, NBOXLZ) 
117: ELSE 
118:     WIDTH = 2.D0 * PI 
119: END IF 
120:  
121: ! Initialise BnB nodes 
122: IDNUM = 1 
123: ! Standard search region 
124: CALL ADDNODE(VECTOR,WIDTH,IDNUM,BESTUPPER,.TRUE.,LOWERBOUND,UPPERBOUND) 
125:  
126: IF(BULKT.AND.OHCELLT) THEN 
127:     ! Adding all 48 octahedral symmetries 
128:     DO IDNUM=2,48 
129:         CALL ADDNODE(VECTOR,WIDTH,IDNUM,BESTUPPER,.TRUE.,LOWERBOUND,UPPERBOUND) 
130:     END DO 
131: ELSE IF(PERMINVOPT) THEN 
132:     ! Adding permutation inversion isomer 
133:     CALL ADDNODE(VECTOR,WIDTH,2,BESTUPPER,.TRUE.,LOWERBOUND,UPPERBOUND) 
134: END IF 
135:  
136: ! Perform BnB 
137: CALL RUN(NSTEPS,.FALSE.,1,BESTUPPER) 
138:  
139: ! Return results 
140: COORDSB(:) = SAVECOORDSB(:) 
141: COORDSA(:) = BESTCOORDSA(:,BESTID) 
142:  
143: DISTANCE = BESTUPPER 
144: DIST2 = DISTANCE**2 
145:  
146: IF(.NOT.NBULKT) THEN 
147:     RMATBEST = BESTRMAT(:,:,BESTID) 
148: ENDIF 
149:  
150: END SUBROUTINE BNB_ALIGN 
151:  
152: SUBROUTINE RUNGROUP(NITER, FORCE, IPRINT, BESTUPPER, NSTRUCTS, UPDATE) 
153: IMPLICIT NONE 
154:  
155: INTEGER, INTENT(IN) :: NITER, IPRINT, NSTRUCTS, UPDATE 
156: LOGICAL, INTENT(IN) :: FORCE 
157: DOUBLE PRECISION, INTENT(INOUT) :: BESTUPPER(NSTRUCTS) 
158:  
159:  
160: DOUBLE PRECISION LOWERBOUND, UPPERBOUND, VECTOR(3), WIDTH 
161: INTEGER I,IDNUM,NODEITER,NSUCCESS 
162:  
163: DO I=1,NITER 
164:  
165:     CALL QUEUEGET(LOWERBOUND, UPPERBOUND, VECTOR, WIDTH, NODEITER, IDNUM) 
166:  
167:     CALL BRANCH(VECTOR,WIDTH,IDNUM,BESTUPPER(IDNUM),FORCE) 
168:  
169:     IF(DEBUG.AND.(IPRINT.GT.0).AND.(MOD(I,IPRINT).EQ.0)) THEN 
170:         WRITE(MYUNIT,'(A)') & 
171:          & "gopermdist> -----------------STATUS UPDATE----------------" 
172:         WRITE(MYUNIT,'(A,I16)') & 
173:          & "gopermdist> iteration  number           = ", I 
174: !        WRITE(MYUNIT,'(A,G20.6)') & 
175: !         & "gopermdist> lowest upper bound so far   = ", BESTUPPER 
176:         WRITE(MYUNIT,'(A,G20.6)') & 
177:          & "gopermdist> highest lower bound so far  = ", LOWERBOUND 
178:         WRITE(MYUNIT,'(A,I16)') & 
179:          & "gopermdist> total calculations so far   = ", NCALC 
180:         WRITE(MYUNIT,'(A,I16)') & 
181:          & "gopermdist> queue length                = ", QUEUELEN() 
182:         WRITE(MYUNIT,'(A)') & 
183:          & "gopermdist> ----------------------------------------------" 
184:     ENDIF 
185:  
186:  
187:     IF(QUEUELEN().LE.0) THEN 
188:         IF(DEBUG) WRITE(MYUNIT,'(A)') & 
189:              & "gopermdist> priority queue empty, stopping" 
190:     END IF 
191:  
192: !    IF((QUEUELEN().LE.0).OR.((LOWERBOUND).GT.(BESTUPPER - RTOL*BESTUPPER - ATOL))) THEN 
193: !        IF(DEBUG) THEN 
194: !            WRITE(MYUNIT,'(A)') & 
195: !             & "gopermdist> -------------------SUCCESS--------------------" 
196: !!            WRITE(MYUNIT,'(A,G20.6)') & 
197: !!             & "gopermdist> converged on minimum RMSD   = ", BESTUPPER 
198: !            WRITE(MYUNIT,'(A,I16)') & 
199: !             & "gopermdist> total calculations          = ", NCALC 
200: !            WRITE(MYUNIT,'(A,I16)') & 
201: !             & "gopermdist> found best on iteration     = ", BESTITER 
202: !            WRITE(MYUNIT,'(A,I16)') & 
203: !             & "gopermdist> best structure              = ", BESTID 
204: !            WRITE(MYUNIT,'(A)') & 
205: !             & "gopermdist> -------------------SUCCESS--------------------" 
206: !        END IF 
207: !        EXIT 
208: !    END IF 
209:  
210: END DO 
211:  
212: END SUBROUTINE RUNGROUP 
213:  
214: SUBROUTINE RUN(NITER, FORCE, IPRINT, BESTUPPER) 
215: IMPLICIT NONE 
216:  
217: INTEGER, INTENT(IN) :: NITER, IPRINT 
218: LOGICAL, INTENT(IN) :: FORCE 
219: DOUBLE PRECISION, INTENT(INOUT) :: BESTUPPER 
220:  
221: DOUBLE PRECISION LOWERBOUND, UPPERBOUND, VECTOR(3), WIDTH 
222: INTEGER I,IDNUM,NODEITER 
223:  
224: DO I=1,NITER 
225:  
226:     CALL QUEUEGET(LOWERBOUND, UPPERBOUND, VECTOR, WIDTH, NODEITER, IDNUM) 
227:  
228:     IF(DEBUG.AND.(IPRINT.GT.0).AND.(MOD(I,IPRINT).EQ.0)) THEN 
229:         WRITE(MYUNIT,'(A)') & 
230:          & "gopermdist> -----------------STATUS UPDATE----------------" 
231:         WRITE(MYUNIT,'(A,I16)') & 
232:          & "gopermdist> iteration  number           = ", I 
233:         WRITE(MYUNIT,'(A,G20.6)') & 
234:          & "gopermdist> lowest upper bound so far   = ", BESTUPPER 
235:         WRITE(MYUNIT,'(A,G20.6)') & 
236:          & "gopermdist> highest lower bound so far  = ", LOWERBOUND 
237:         WRITE(MYUNIT,'(A,I16)') & 
238:          & "gopermdist> total calculations so far   = ", NCALC 
239:         WRITE(MYUNIT,'(A,I16)') & 
240:          & "gopermdist> queue length                = ", QUEUELEN() 
241:         WRITE(MYUNIT,'(A)') & 
242:          & "gopermdist> ----------------------------------------------" 
243:     ENDIF 
244:  
245:     CALL BRANCH(VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE) 
246:  
247:     IF(QUEUELEN().LE.0) THEN 
248:         IF(DEBUG) WRITE(MYUNIT,'(A)') & 
249:              & "gopermdist> priority queue empty, stopping" 
250:     END IF 
251:  
252:     IF((QUEUELEN().LE.0).OR.((LOWERBOUND).GT.(BESTUPPER - RTOL*BESTUPPER - ATOL))) THEN 
253:         IF(DEBUG) THEN 
254:             WRITE(MYUNIT,'(A)') & 
255:              & "gopermdist> -------------------SUCCESS--------------------" 
256:             WRITE(MYUNIT,'(A,G20.6)') & 
257:              & "gopermdist> converged on minimum RMSD   = ", BESTUPPER 
258:             WRITE(MYUNIT,'(A,I16)') & 
259:              & "gopermdist> total calculations          = ", NCALC 
260:             WRITE(MYUNIT,'(A,I16)') & 
261:              & "gopermdist> found best on iteration     = ", BESTITER 
262:             WRITE(MYUNIT,'(A,I16)') & 
263:              & "gopermdist> best structure              = ", BESTID 
264:             WRITE(MYUNIT,'(A)') & 
265:              & "gopermdist> -------------------SUCCESS--------------------" 
266:         END IF 
267:         EXIT 
268:     END IF 
269:  
270: END DO 
271:  
272: END SUBROUTINE 
273:  
274: SUBROUTINE ADDNODE(VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE,LOWERBOUND,UPPERBOUND) 
275:  
276: IMPLICIT NONE 
277: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3), WIDTH 
278: DOUBLE PRECISION, INTENT(INOUT) :: BESTUPPER 
279: DOUBLE PRECISION, INTENT(OUT) :: LOWERBOUND, UPPERBOUND 
280: INTEGER, INTENT(IN) :: IDNUM 
281: LOGICAL, INTENT(IN) :: FORCE 
282:  
283: DOUBLE PRECISION :: DIST2 
284:  
285: LOGICAL :: PERMINVOPTSAVE, OHCELLTSAVE, PERMOPTSAVE 
286:  
287: CALL CALCBOUNDS(LOWERBOUND,UPPERBOUND,VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE) 
288:  
289: ! If upperbound within tolerance of lowest upperbound then quench with 
290: ! minpermdist 
291: IF ((UPPERBOUND).LE.(BESTUPPER + MPRTOL*BESTUPPER + ATOL)) THEN 
292:     PERMINVOPTSAVE = PERMINVOPT; OHCELLTSAVE = OHCELLT; PERMOPTSAVE = PERMOPT 
293:     OHCELLT = .FALSE.; PERMINVOPT = .FALSE. 
294:     ! sn402: the following line shouldn't be necessary any more: PERMOPT should be set at align_decide 
295: !    PERMOPT = .NOT. BULKT  ! PERMOPT needs to be FALSE for periodic alignments but true for cluster alignments 
296:  
297:     CALL MINPERMDIST(SAVECOORDSB,DUMMYA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,BULKT, & 
298:  & .FALSE.,UPPERBOUND,DIST2,.FALSE.,DUMMYRMAT) 
299:  
300:     ! Resetting keywords 
301:     PERMINVOPT = PERMINVOPTSAVE; OHCELLT = OHCELLTSAVE; PERMOPT = PERMOPTSAVE 
302:     NQUENCH = NQUENCH + 1 
303:  
304:     IF(DEBUG) WRITE(MYUNIT, "(A,G20.5)") & 
305:  & "gopermdist> post quench new lowest RMSD = ", UPPERBOUND 
306: END IF 
307:  
308: IF (UPPERBOUND.LT.BESTUPPER) THEN 
309:  
310:     BESTUPPER = UPPERBOUND 
311:  
312:     IF(DEBUG) WRITE(MYUNIT, "(A,G20.5)") & 
313:  & "gopermdist> NEW lowest upper bound RMSD = ", UPPERBOUND 
314:  
315: !    ! Don't need to test for inversion isomers 
316: !    PERMINVOPTSAVE = PERMINVOPT; OHCELLTSAVE = OHCELLT 
317: !    OHCELLT = .FALSE.; PERMINVOPT = .FALSE. 
318: ! 
319: !    CALL MINPERMDIST(SAVECOORDSB,DUMMYA,NATOMS,DEBUG,BOXLX,BOXLY,BOXLZ,BULKT, & 
320: ! & .FALSE.,BESTUPPER,DIST2,.FALSE.,DUMMYRMAT) 
321: ! 
322: !    ! Resetting keywords 
323: !    PERMINVOPT = PERMINVOPTSAVE; OHCELLT = OHCELLTSAVE 
324: !    NQUENCH = NQUENCH + 1 
325:  
326:     IF (.NOT.BULKT) BESTRMAT(:,:,IDNUM) = MATMUL(TRMAT,DUMMYRMAT) 
327:     BESTCOORDSA(:,IDNUM) = DUMMYA 
328:     BESTID = IDNUM 
329:     BESTITER = NCALC 
330:     CALL QUEUEPUT(LOWERBOUND,UPPERBOUND,VECTOR,WIDTH,NCALC,IDNUM) 
331:  
332: ELSE IF( (LOWERBOUND ).LT.(BESTUPPER - RTOL*BESTUPPER - ATOL) ) THEN 
333:     CALL QUEUEPUT(LOWERBOUND,UPPERBOUND,VECTOR,WIDTH,NCALC,IDNUM) 
334: END IF 
335:  
336:  
337:  
338: END SUBROUTINE ADDNODE 
339:  
340: SUBROUTINE BRANCH(VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE) 
341:  
342: IMPLICIT NONE 
343: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3), WIDTH 
344: DOUBLE PRECISION, INTENT(INOUT) :: BESTUPPER 
345: INTEGER, INTENT(IN) :: IDNUM 
346: LOGICAL, INTENT(IN) :: FORCE 
347:  
348: DOUBLE PRECISION :: LOWERBOUND, UPPERBOUND, NEWVECT(3),MINR 
349:  
350: INTEGER I 
351:  
352: DO I=1,8 
353:     NEWVECT(:) = VECTOR + LVECS(:,I)*WIDTH*0.25D0 
354:     ! Check if rotation is within sphere 
355:     IF(BULKT.OR.((SUM(NEWVECT**2)-0.75D0*WIDTH**2).LE.(PI**2))) CALL ADDNODE( & 
356: & NEWVECT,WIDTH*0.5D0,IDNUM,BESTUPPER,FORCE,LOWERBOUND,UPPERBOUND) 
357: END DO 
358:  
359: END SUBROUTINE BRANCH 
360:  
361: SUBROUTINE CALCBOUNDS(LOWERBOUND,UPPERBOUND,VECTOR,WIDTH,IDNUM,BESTUPPER,FORCE) 
362:  
363: USE COMMONS, ONLY: NATOMS 
364:  
365: IMPLICIT NONE 
366: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3), WIDTH, BESTUPPER 
367: INTEGER, INTENT(IN) :: IDNUM 
368: LOGICAL, INTENT(IN) :: FORCE 
369:  
370: DOUBLE PRECISION, INTENT(OUT) :: LOWERBOUND, UPPERBOUND 
371:  
372: DOUBLE PRECISION W,SINW,COSW,RA,RB,ESTLOWER,ESTUPPER,D,V,COSP 
373: INTEGER I,J,J1,M,K,K1,IND,NDUMMY,NPERM,INFO,IA,IB 
374: LOGICAL RECALC 
375:  
376: DOUBLE PRECISION PERMDIST 
377:  
378: IF(BULKT) THEN 
379:     W = SQRT(3.D0) * WIDTH * 0.5D0 
380: ELSE 
381:     V = SQRT(SUM(VECTOR**2)) 
382:     COSP = V/SQRT(V**2 + 0.75*WIDTH**2) 
383:     !COSP = (V-WIDTH*0.5D0)/SQRT(V**2 - V*WIDTH + 0.5*WIDTH**2) 
384:     COSW = MIN(COS(WIDTH*0.5D0), (COS(V)**2 + COSP*SIN(V)**2) * COS(WIDTH*0.5D0) - & 
385:      & (1-COSP)*ABS(SIN(V)*COS(V)*SIN(WIDTH*0.5D0)) ) 
386: !    COSW = COS(W) 
387:     SINW = SQRT(1.D0 - COSW**2) 
388: END IF 
389:  
390: IF(DEBUG) THEN 
391:     IF(BULKT) WRITE(MYUNIT, "(A,3F16.5)") & 
392:  & "gopermdist> testing displacement vector = ", VECTOR 
393:     IF(.NOT.BULKT) WRITE(MYUNIT, "(A,3F16.5)") & 
394:  & "gopermdist> testing angle-axis vector   = ", VECTOR 
395:     WRITE(MYUNIT, "(A,G20.5,A,I4)") & 
396:  & "gopermdist> with width                  = ", WIDTH, & 
397:  & "     on IDNUM    =", IDNUM 
398: END IF 
399:  
400: CALL TRANSFORM(DUMMYA, NATOMS, VECTOR, IDNUM) 
401:  
402: ! Find distance matrix 
403: CALL PERMPAIRDISTS(SAVECOORDSB,DUMMYA,NATOMS,PMAXNEI,DUMMYDISTS,DUMMYIDX,NPERMGROUP) 
404:  
405: !write(*,*) (dummyidx) 
406:  
407: ! Find bounded distanace matrix 
408: IF(BULKT) THEN 
409:     NDUMMY=0 
410:     DO J1=1,NPERMGROUP 
411:         NPERM=NPERMSIZE(J1) 
412:         M = MIN(NPERM,PMAXNEI) 
413:         DUMMYLDISTS(:NPERM*M,J1) = MAX(SQRT(DUMMYDISTS(:NPERM*M,J1)) - W,0.D0)**2 
414:     ENDDO 
415: ELSE 
416:     NDUMMY=0 
417:     DO J1=1,NPERMGROUP 
418:         NPERM = NPERMSIZE(J1) 
419:         M = MIN(NPERM,PMAXNEI) 
420:         DO J=1,NPERM 
421:             K=M*(J-1) 
422:             RB = SAVERB(PERMGROUP(J+NDUMMY)) 
423:             DO I=1,M 
424:                 IND = K+I 
425:                 RA = SAVERA(PERMGROUP(DUMMYIDX(IND,J1)+NDUMMY),IDNUM) 
426:                 DUMMYLDISTS(IND,J1) = BOUNDROTDISTANCE( & 
427:                      & DUMMYDISTS(IND,J1),COSW,SINW,RB,RA) 
428:             END DO 
429:         ENDDO 
430:     NDUMMY = NDUMMY + NPERMSIZE(J1) 
431:     ENDDO 
432: END IF 
433:  
434: ! Estimating upperbound by finding nearest neighbours 
435: IF((.NOT.FORCE).OR.DEBUG) THEN 
436:     CALL PERMNEARESTNEIGHBOURDISTS(DUMMYDISTS,DUMMYIDX,NATOMS,PMAXNEI, & 
437:      & DUMMYNEARIDX,DUMMYNEARDISTS,NPERMGROUP) 
438:  
439:     UPPERBOUND = SUM(DUMMYNEARDISTS)**0.5 
440:     IF(DEBUG) WRITE(MYUNIT, "(A,G20.5,A)") & 
441:  & "gopermdist> estimate for upper bound    = ", UPPERBOUND 
442:  
443:     ! Check if permutation has been found anyway 
444:     IF(UPPERBOUND.LT.BESTUPPER) THEN 
445:         LPERM = 0 
446:         DO J1=1,NATOMS 
447:             LPERM(DUMMYNEARIDX(J1)) = 1 
448:         END DO 
449:         IF(ALL(LPERM.EQ.1)) THEN 
450:             RECALC = .FALSE. 
451:             IF(DEBUG) WRITE(MYUNIT, "(A)") & 
452:  & "gopermdist> nearest neighbours are best permutation" 
453:         ELSE 
454:             RECALC = .TRUE. 
455:         END IF 
456:     ELSE 
457:         RECALC = .FALSE. 
458:     END IF 
459:     ESTUPPER = UPPERBOUND 
460: END IF 
461:  
462:  
463: ! Estimating Lower Bound by finding nearest neighbours 
464: IF(DEBUG.OR.(.NOT.(FORCE.OR.RECALC))) THEN 
465:     IF(BULKT) THEN 
466: !        DO J1=1,NPERMGROUP 
467: !            NPERM=NPERMSIZE(J1) 
468: !            M = MIN(NPERM,PMAXNEI) 
469: !            DUMMYLDISTS(:NPERM*M,J1) = MAX(SQRT(DUMMYDISTS(:NPERM*M,J1)) - W,0.D0)**2 
470: !        ENDDO 
471:  
472:         ! Find relative displacements 
473:         DO J1=1,NPERMGROUP 
474:             NPERM=NPERMSIZE(J1) 
475:             M = MIN(NPERM,PMAXNEI) 
476:             DO I=1,NPERM 
477:                 IB = PERMGROUP(I+NDUMMY) 
478:                 K = M*(I-1) 
479:                 DO J=1,M 
480:                     IA = PERMGROUP(DUMMYIDX(K+J,J1)+NDUMMY) 
481:                     DUMMYDISPS(:,K+J,J1) = SAVECOORDSB(3*IB-2:3*IB) - DUMMYA(3*IA-2:3*IA) 
482:                     DUMMYDISPS(1,K+J,J1) = DUMMYDISPS(1,K+J,J1) - & 
483:                      & NINT(DUMMYDISPS(1,K+J,J1)/BOXLX) * BOXLX 
484:                     DUMMYDISPS(2,K+J,J1) = DUMMYDISPS(2,K+J,J1) - & 
485:                      & NINT(DUMMYDISPS(2,K+J,J1)/BOXLY) * BOXLY 
486:                     DUMMYDISPS(3,K+J,J1) = DUMMYDISPS(3,K+J,J1) - & 
487:                      & NINT(DUMMYDISPS(3,K+J,J1)/BOXLZ) * BOXLZ 
488:  
489:                     DUMMYDOTDISP(:,K+J,J1) = MATMUL(DUMMYDISPS(:,K+J,J1),LVECS(:,1:4)) 
490:                 END DO 
491:             END DO 
492:             NDUMMY = NDUMMY + NPERM 
493:         END DO 
494:  
495:         ESTLOWER = HUGE(1.D0) 
496:         DO I=1,6 
497:             DO J1=1,NPERMGROUP 
498:                 NPERM=NPERMSIZE(J1) 
499:                 M = MIN(NPERM,PMAXNEI) 
500:                 DUMMYLDISTS2(:M*NPERM,J1) = MERGE(DUMMYDISTS(:M*NPERM,J1), & 
501:                                                 & DUMMYLDISTS(:M*NPERM,J1), & 
502:                  & MATMUL(FVECS(:,I),DUMMYDOTDISP(:,:M*NPERM,J1)).GT.0.D0) 
503:             END DO 
504:  
505:             CALL PERMNEARESTNEIGHBOURDISTS(DUMMYLDISTS2,DUMMYIDX,NATOMS, & 
506:              & PMAXNEI,DUMMYNEARIDX,DUMMYNEARLDISTS,NPERMGROUP) 
507:  
508:             D = SUM(DUMMYNEARLDISTS) 
509:             ESTLOWER = MIN(D, ESTLOWER) 
510:  
511:             IF(DEBUG) WRITE(MYUNIT, "(A,I16,A,G10.5)") & 
512:      & "gopermdist> estimating for face         = ", I, & 
513:      & "         lower bound = ", D**0.5 
514:         END DO 
515:         ESTLOWER = SQRT(ESTLOWER) 
516:  
517:     ELSE 
518:         CALL PERMNEARESTNEIGHBOURDISTS(DUMMYLDISTS,DUMMYIDX,NATOMS,PMAXNEI, & 
519:          & DUMMYNEARIDX,DUMMYNEARLDISTS,NPERMGROUP) 
520:  
521:         ESTLOWER = SUM(DUMMYNEARLDISTS)**0.5 
522:     END IF 
523:  
524:     LOWERBOUND = ESTLOWER 
525:  
526:     IF(DEBUG) WRITE(MYUNIT, "(A,G20.5)") & 
527:      & "gopermdist> estimate for lower bound    = ", ESTLOWER 
528:  
529: END IF 
530:  
531:  
532:  
533:  
534: ! If estimate of upperbound is lower than best found upperbound we need to 
535: ! solve assignment problem to find bounds 
536: IF (FORCE.OR.RECALC) THEN 
537:  
538:     ! Need to calculate this matrix to get total distance from reduced distance 
539:     ! matrix and total permutation 
540:     CALL INVPAIRDISTIDX(DUMMYIDX, DINVIDX, NATOMS, PMAXNEI, NPERMGROUP) 
541:  
542: !    DINVIDX = -1 
543: !    DO J1=1,NPERMGROUP 
544: !        NPERM = NPERMSIZE(J1) 
545: !        M = MIN(NPERM,PMAXNEI) 
546: !        DO J=1,NPERM 
547: !            K=M*(J-1) 
548: !            K1 = NPERM*(J-1) 
549: !            DO I=1,M 
550: !                DINVIDX(K1+DUMMYIDX(K+I,J1),J1) = I 
551: !            END DO 
552: !        END DO 
553: !    END DO 
554:  
555:     IF(BULKT) THEN 
556:         DO J1=1,NPERMGROUP 
557:             NPERM=NPERMSIZE(J1) 
558: !            M = MERGE(NPERM,PMAXNEI,NPERM.LT.PMAXNEI) 
559:             M = MIN(NPERM,PMAXNEI) 
560:             DUMMYLDISTS(:NPERM*M,J1) = MAX(SQRT(DUMMYDISTS(:NPERM*M,J1)) - W,0.D0)**2 
561:         ENDDO 
562:     END IF 
563:  
564:     CALL FINDBESTPERM(DUMMYLDISTS,DUMMYIDX,NATOMS,PMAXNEI,NEWPERM, & 
565:      & LOWERBOUND,NPERMGROUP, INFO) 
566:  
567:     CALL FINDPERMVAL(NEWPERM,NATOMS,DUMMYLDISTS,DINVIDX,PMAXNEI,NPERMGROUP,LOWERBOUND) 
568: !    LOWERBOUND = 0.D0 
569: !    NDUMMY = 0 
570: !    DO J1=1,NPERMGROUP 
571: !        NPERM = NPERMSIZE(J1) 
572: !        M = MIN(NPERM,PMAXNEI) 
573: !        DO J=1,NPERM 
574: !!            K = M*(J-1) 
575: !!            K1 = NPERM*(J-1) 
576: !            IA = INVPERMGROUP(NEWPERM(PERMGROUP(J+NDUMMY)))-NDUMMY 
577: !            I = DINVIDX(NPERM*(J-1)+IA,J1) 
578: !            LOWERBOUND = LOWERBOUND + DUMMYLDISTS(M*(J-1)+I,J1) 
579: !        END DO 
580: !        NDUMMY = NDUMMY + NPERM 
581: !    END DO 
582:  
583: !    LOWERBOUND = 0.D0 
584: !    ! Perhaps there's a better way of calculating lowerbound from FINDBESTPERM? 
585: !    DO J=1,NATOMS 
586: !        I = NEWPERM(J) 
587: !        LOWERBOUND = (LOWERBOUND + MAX(SQRT(PERMDIST( & 
588: !         & SAVECOORDSB(3*J-2:3*J),DUMMYA(3*I-2:3*I),BOXVEC,BULKT))-W,0.D0)**2) 
589: !    END DO 
590:  
591:     ! Check output of assignment problem 
592:     IF(INFO.GT.0) THEN 
593:         LOWERBOUND = 0.D0 
594:         IF(DEBUG) WRITE(MYUNIT, "(A,I3)") & 
595:  & "gopermdist> WARNING LAP algorithm failed to align npoints= ", INFO 
596:     ELSE 
597:         LOWERBOUND = SQRT(LOWERBOUND) 
598:         IF(DEBUG) WRITE(MYUNIT, "(A,G20.5)") & 
599:  & "gopermdist> calculated lower bound RMSD = ", LOWERBOUND 
600:     END IF 
601:     ! Calculate upperbound if lowerbound lower than bestupper 
602:     IF((LOWERBOUND.LT.BESTUPPER).OR.FORCE) THEN 
603:         CALL FINDBESTPERM(DUMMYDISTS,DUMMYIDX,NATOMS,PMAXNEI,LPERM, & 
604:          & UPPERBOUND,NPERMGROUP, INFO) 
605:  
606:         CALL FINDPERMVAL(LPERM,NATOMS,DUMMYDISTS,DINVIDX,PMAXNEI,NPERMGROUP,UPPERBOUND) 
607:  
608: !        UPPERBOUND = 0.D0 
609: !        NDUMMY = 0 
610: !        DO J1=1,NPERMGROUP 
611: !            NPERM = NPERMSIZE(J1) 
612: !            M = MIN(NPERM,PMAXNEI) 
613: !            DO J=1,NPERM 
614: !!                K = M*(J-1) 
615: !!                K1 = NPERM*(J-1) 
616: !                IA = INVPERMGROUP(NEWPERM(PERMGROUP(J+NDUMMY)))-NDUMMY 
617: !                I = DINVIDX(NPERM*(J-1)+IA,J1) 
618: !                UPPERBOUND = UPPERBOUND + DUMMYDISTS(M*(J-1)+I,J1) 
619: !            END DO 
620: !            NDUMMY = NDUMMY + NPERM 
621: !        END DO 
622:  
623: !        UPPERBOUND = 0.D0 
624: !        DO J=1,NATOMS 
625: !            I = LPERM(J) 
626: !            UPPERBOUND = (UPPERBOUND + PERMDIST( & 
627: !         & SAVECOORDSB(3*J-2:3*J),DUMMYA(3*I-2:3*I),BOXVEC,BULKT)) 
628: !        END DO 
629:  
630:         ! Check output of assignment problem 
631:         IF(INFO.GT.0) THEN 
632:             UPPERBOUND = HUGE(1.D0) 
633:             IF(DEBUG) WRITE(MYUNIT, "(A,I3)") & 
634:  & "gopermdist> WARNING LAP algorithm failed to align npoints= ", INFO 
635:         ELSE 
636:             UPPERBOUND = SQRT(UPPERBOUND) 
637:             IF(DEBUG) WRITE(MYUNIT, "(A,G20.5)") & 
638:  & "gopermdist> calculated upper bound RMSD = ", UPPERBOUND 
639:         END IF 
640:     ELSE 
641:         UPPERBOUND = HUGE(1.D0) 
642:     END IF 
643: END IF 
644:  
645: IF (DEBUG.AND.((ESTUPPER.GT.UPPERBOUND).OR.(ESTLOWER.GT.LOWERBOUND))) THEN 
646:     WRITE(MYUNIT,"(A)") "gopermdist>************WARNING*********************" 
647:     WRITE(MYUNIT,"(A)") "EST UPPER GT UPPERBOUND OR EST LOWER GT LOWERBOUND" 
648:     WRITE(MYUNIT,"(A)") "gopermdist>************WARNING*********************" 
649:     NBAD = NBAD + 1 
650: ENDIF 
651:  
652: NCALC = NCALC + 1 
653:  
654: END SUBROUTINE CALCBOUNDS 
655:  
656: SUBROUTINE FINDPERMVAL(PERM, NATOMS, MATVALS, DINVIDX, MAXNEI, NPERMGROUP, BEST) 
657:  
658: IMPLICIT NONE 
659: INTEGER, INTENT(IN) :: PERM(NATOMS), NATOMS, DINVIDX(NATOMS*NATOMS,NPERMGROUP), & 
660:  & MAXNEI, NPERMGROUP 
661: DOUBLE PRECISION, INTENT(IN) :: MATVALS(NATOMS*MAXNEI,NPERMGROUP) 
662: DOUBLE PRECISION, INTENT(OUT) :: BEST 
663:  
664: INTEGER J1,M,J,I,IA,NPERM,NDUMMY 
665:  
666: BEST = 0.D0 
667: NDUMMY = 0 
668: DO J1=1,NPERMGROUP 
669:     NPERM = NPERMSIZE(J1) 
670:     M = MIN(NPERM,MAXNEI) 
671:     DO J=1,NPERM 
672:         IA = INVPERMGROUP(PERM(PERMGROUP(J+NDUMMY)))-NDUMMY 
673:         I = DINVIDX(NPERM*(J-1)+IA,J1) 
674:         BEST = BEST + MATVALS(M*(J-1)+I,J1) 
675:     END DO 
676:     NDUMMY = NDUMMY + NPERM 
677: END DO 
678:  
679: END SUBROUTINE FINDPERMVAL 
680:  
681: SUBROUTINE INVPAIRDISTIDX(DUMMYIDX, DINVIDX, NATOMS, MAXNEI, NPERMGROUP) 
682:  
683: IMPLICIT NONE 
684: INTEGER, INTENT(IN) :: DUMMYIDX(NATOMS*MAXNEI,NPERMGROUP), NATOMS, MAXNEI, NPERMGROUP 
685: INTEGER, INTENT(OUT) :: DINVIDX(NATOMS*NATOMS,NPERMGROUP) 
686: INTEGER J1,NPERM,I,J,M 
687:  
688: DINVIDX = -1 
689: DO J1=1,NPERMGROUP 
690:     NPERM = NPERMSIZE(J1) 
691:     M = MIN(NPERM,MAXNEI) 
692:     DO J=1,NPERM 
693:         DO I=1,M 
694:             DINVIDX(NPERM*(J-1)+DUMMYIDX(M*(J-1)+I,J1),J1) = I 
695:         END DO 
696:     END DO 
697: END DO 
698:  
699: END SUBROUTINE INVPAIRDISTIDX 
700:  
701: SUBROUTINE PERMNEARESTNEIGHBOURDISTS(NDISTS,NIDX,NATOMS,MAXNEI,NEARI,NEARD,NPERMGROUP) 
702:  
703: IMPLICIT NONE 
704: INTEGER, INTENT(IN) :: NATOMS,MAXNEI,NPERMGROUP,NIDX(MAXNEI*NATOMS,NPERMGROUP) 
705: DOUBLE PRECISION, INTENT(IN) :: NDISTS(MAXNEI*NATOMS,NPERMGROUP) 
706:  
707: INTEGER, INTENT(OUT) :: NEARI(NATOMS) 
708: DOUBLE PRECISION, INTENT(OUT) :: NEARD(NATOMS) 
709:  
710: INTEGER I, J1, J2, IND, NPERM, NDUMMY, M 
711:  
712: NDUMMY = 0 
713: DO J1=1,NPERMGROUP 
714:     NPERM=NPERMSIZE(J1) 
715: !    M = MERGE(NPERM,MAXNEI,NPERM.LT.MAXNEI) 
716:     M = MIN(NPERM,PMAXNEI) 
717:     CALL NEARESTNEIGHBOURDISTS(NDISTS(1:NPERM*M,J1),NIDX(1:NPERM*M,J1), & 
718:  & NPERM,M,LPERM(1:NPERM),PDUMMYND(1:NPERM)) 
719:  
720:     DO J2=1,NPERM 
721:         IND = LPERM(J2) 
722:         NEARI(PERMGROUP(NDUMMY+J2)) = PERMGROUP(NDUMMY + IND) 
723:         NEARD(PERMGROUP(NDUMMY+J2)) = PDUMMYND(J2) 
724:     END DO 
725:     NDUMMY = NDUMMY + NPERM 
726: END DO 
727:  
728: END SUBROUTINE PERMNEARESTNEIGHBOURDISTS 
729:  
730: SUBROUTINE NEARESTNEIGHBOURDISTS(CC, KK, N, MAXNEI, IDX, DISTS) 
731:  
732: IMPLICIT NONE 
733:  
734: INTEGER, INTENT(IN) :: N, MAXNEI, KK(MAXNEI*N) 
735: DOUBLE PRECISION, INTENT(IN) :: CC(MAXNEI*N) 
736:  
737: INTEGER, INTENT(OUT) :: IDX(N) 
738: DOUBLE PRECISION, INTENT(OUT) :: DISTS(N) 
739:  
740: INTEGER I,J,K,M 
741:  
742: M=MAXNEI 
743: IF(N.LT.MAXNEI) M=N 
744:  
745: DO I=1,N 
746:     J = MINLOC(CC(M*(I-1)+1:M*I),1) 
747:     DISTS(I) = CC(M*(I-1) + J) 
748:     IDX(I)   = KK(M*(I-1) + J) 
749: END DO 
750:  
751: END SUBROUTINE NEARESTNEIGHBOURDISTS 
752:  
753: SUBROUTINE FINDBESTPERM(NDISTS,NIDX,NATOMS,MAXNEI,PERM,DIST,NPERMGROUP,INFO) 
754: ! DISTANCE RETURN INACCURATE 
755: IMPLICIT NONE 
756:  
757: INTEGER, INTENT(IN) :: NATOMS,NPERMGROUP,MAXNEI,NIDX(MAXNEI*NATOMS,NPERMGROUP) 
758: DOUBLE PRECISION, INTENT(IN) :: NDISTS(MAXNEI*NATOMS,NPERMGROUP) 
759:  
760: DOUBLE PRECISION, INTENT(OUT) :: DIST 
761: INTEGER, INTENT(OUT) :: PERM(NATOMS), INFO 
762:  
763: ! COULD SET THESE AS MODULE VARIABLES 
764: INTEGER*8 :: KK(NATOMS*MAXNEI), CC(NATOMS*MAXNEI) 
765: INTEGER*8 :: FIRST(NATOMS+1), X(NATOMS), Y(NATOMS) 
766: INTEGER*8 :: U(NATOMS), V(NATOMS), N8, SZ8, H 
767: INTEGER N,M,I,J,K,K1,I1,J1,NDUMMY 
768:  
769: DIST = 0.D0 
770: INFO=0 
771:  
772: NDUMMY=0 
773:  
774: DO J1=1,NPERMGROUP 
775:  
776:     N = NPERMSIZE(J1) 
777:     M = MAXNEI 
778:     IF(N.LE.MAXNEI) M=N 
779:     SZ8 = M*N 
780:     N8 = N 
781:  
782:     DO I=0,N 
783:         FIRST(I+1) = I*M +1 
784:     ENDDO 
785:     KK = -1 
786:     CC = HUGE(1) 
787:     DO J=1,N 
788:         K = FIRST(J)-1 
789:         DO I=1,M 
790:             KK(I+K) = NIDX(I+K,J1) 
791:             CC(I+K) = INT(NDISTS(I+K,J1)*PSCALE, 8) 
792:         ENDDO 
793:     ENDDO 
794:  
795:     CALL JOVOSAP(N8, SZ8, CC(:M*N), KK(:M*N), FIRST(:N+1), Y(:N), X(:N), U(:N), V(:N), H) 
796:     NLAP = NLAP + 1 
797:  
798:     DO I=1,N 
799:         IF (Y(I).GT.N) THEN 
800:             Y(I)=N 
801:             INFO = INFO + 1 
802:         END IF 
803:         IF (Y(I).LT.1) THEN 
804:             Y(I)=1 
805:             INFO = INFO + 1 
806:         END IF 
807:         PERM(PERMGROUP(NDUMMY+I)) = PERMGROUP(NDUMMY+Y(I)) 
808:     ENDDO 
809:     DIST = DIST + H/PSCALE 
810:  
811:     ! untested!! 
812:     IF (NSETS(J1).GT.0) THEN 
813:         DO I=1,N 
814:             DO K=1,NSETS(J1) 
815:                 PERM(SETS(PERMGROUP(NDUMMY+I),K))=SETS(PERM(PERMGROUP(NDUMMY+Y(I))),K) 
816:             ENDDO 
817:         ENDDO 
818:     ENDIF 
819:  
820:     NDUMMY = NDUMMY + NPERMSIZE(J1) 
821: ENDDO 
822:  
823:  
824: END SUBROUTINE FINDBESTPERM 
825:  
826: SUBROUTINE PERMPAIRDISTS(COORDSB,COORDSA,NATOMS,MAXNEI,NDISTS,NIDX,NPERMGROUP) 
827:  
828: ! Uses module variables BOXLX, BOXLY, BOXLZ, BULKT when calculating periodic distances 
829:  
830: IMPLICIT NONE 
831:  
832: INTEGER, INTENT(IN) :: NATOMS, NPERMGROUP, MAXNEI 
833: DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NATOMS), COORDSB(3*NATOMS) 
834:  
835: INTEGER, INTENT(OUT) :: NIDX(MAXNEI*NATOMS,NPERMGROUP) 
836: DOUBLE PRECISION, INTENT(OUT) :: NDISTS(MAXNEI*NATOMS,NPERMGROUP) 
837:  
838: INTEGER NDUMMY,J1,J2,NPERM 
839:  
840: NDUMMY = 0 
841:  
842: NIDX   = -1 
843: NDISTS = HUGE(1.D0) 
844:  
845: DO J1=1,NPERMGROUP 
846:     NPERM=NPERMSIZE(J1) 
847:     DO J2=1,NPERM 
848:         PDUMMYA(3*(J2-1)+1)=COORDSA(3*((PERMGROUP(NDUMMY+J2))-1)+1) 
849:         PDUMMYA(3*(J2-1)+2)=COORDSA(3*((PERMGROUP(NDUMMY+J2))-1)+2) 
850:         PDUMMYA(3*(J2-1)+3)=COORDSA(3*((PERMGROUP(NDUMMY+J2))-1)+3) 
851:         PDUMMYB(3*(J2-1)+1)=COORDSB(3*((PERMGROUP(NDUMMY+J2))-1)+1) 
852:         PDUMMYB(3*(J2-1)+2)=COORDSB(3*((PERMGROUP(NDUMMY+J2))-1)+2) 
853:         PDUMMYB(3*(J2-1)+3)=COORDSB(3*((PERMGROUP(NDUMMY+J2))-1)+3) 
854:     ENDDO 
855:     CALL PAIRDISTS(NPERM,PDUMMYB(1:3*NPERM),PDUMMYA(1:3*NPERM),BOXLX,BOXLY, & 
856:  & BOXLZ,BULKT,NDISTS(1:MAXNEI*NPERM,J1),NIDX(1:MAXNEI*NPERM,J1),MAXNEI) 
857:     NDUMMY = NDUMMY + NPERM 
858: ENDDO 
859:  
860: END SUBROUTINE PERMPAIRDISTS 
861:  
862: FUNCTION BOUNDROTDISTANCE(D2,COSW,SINW,RA,RB) RESULT(LDIST) 
863:  
864: IMPLICIT NONE 
865: DOUBLE PRECISION, INTENT(IN) :: D2,COSW,SINW,RA,RB 
866: DOUBLE PRECISION LDIST 
867:  
868: DOUBLE PRECISION RARB,RA2RB2,COSAB,SINAB,MCOSAB 
869:  
870: ! Precalculate these? 
871: RARB = 2*RA*RB 
872: RA2RB2 = RA**2 + RB**2 
873:  
874: COSAB = (RA2RB2 - D2)/RARB 
875: SINAB = SQRT(1.D0-MIN(COSAB**2,1.D0)) ! Making sure sqrt is of positive number 
876: MCOSAB = MERGE(1.D0, COSAB*COSW + SINAB*SINW, COSAB.GT.COSW) 
877:  
878: LDIST = MAX(RA2RB2 - RARB*MCOSAB,0.D0) 
879:  
880: END FUNCTION 
881:  
882: FUNCTION QUEUELEN() RESULT(LENGTH) 
883:  
884: IMPLICIT NONE 
885: INTEGER LENGTH 
886:  
887: LENGTH = Q%N 
888:  
889: END FUNCTION 
890:  
891: SUBROUTINE QUEUEGET(LOWERBOUND, UPPERBOUND, VECTOR, WIDTH, NITER, IDNUM) 
892: USE PRIORITYQUEUE, ONLY: NODE, TOP 
893:  
894: IMPLICIT NONE 
895: DOUBLE PRECISION, INTENT(OUT) :: lowerbound, upperbound, vector(3), width 
896: INTEGER, INTENT(OUT) :: niter, IDNUM 
897:  
898: TYPE(NODE) RES 
899:  
900: IF(Q%N.GT.0) THEN 
901:     RES = TOP(Q) 
902:     VECTOR = RES%VECTOR 
903:     UPPERBOUND = RES%UPPERBOUND 
904:     LOWERBOUND = RES%LOWERBOUND 
905:     WIDTH = RES%WIDTH 
906:     NITER = RES%NITER 
907:     IDNUM = RES%IDNUM 
908: ELSE IF(DEBUG) THEN 
909:     WRITE(MYUNIT,"(A)") "gopermdist> warning, trying to read empty list" 
910: ENDIF 
911:  
912: END SUBROUTINE QUEUEGET 
913:  
914: SUBROUTINE QUEUEPUT(LOWERBOUND, UPPERBOUND, VECTOR, WIDTH, NITER, IDNUM) 
915: USE PRIORITYQUEUE, ONLY: ENQUEUE 
916:  
917: IMPLICIT NONE 
918:  
919: DOUBLE PRECISION, INTENT(IN) :: lowerbound, upperbound, vector(3), width 
920: INTEGER, INTENT(IN) :: niter, IDNUM 
921:  
922: CALL ENQUEUE(Q, LOWERBOUND, UPPERBOUND, VECTOR, WIDTH, NITER, IDNUM) 
923:  
924: END SUBROUTINE QUEUEPUT 
925:  
926: SUBROUTINE QUEUECLEAR() 
927: USE PRIORITYQUEUE, ONLY: NODE, TOP 
928:  
929: IMPLICIT NONE 
930: TYPE(NODE) RES 
931:  
932: DO WHILE(Q%N.GT.0) 
933:     RES = TOP(Q) 
934: END DO 
935:  
936: END SUBROUTINE QUEUECLEAR 
937:  
938: SUBROUTINE INITIALISE(COORDSB,COORDSA,NATOMS,NBOXLX,NBOXLY,NBOXLZ,NBULKT) 
939:  
940: !USE COMMONS, ONLY: PERMINVOPT, OHCELLT 
941: IMPLICIT NONE 
942:  
943: INTEGER, INTENT(IN) :: NATOMS 
944: DOUBLE PRECISION, INTENT(IN) :: COORDSB(3*NATOMS), COORDSA(3*NATOMS), & 
945:  & NBOXLX, NBOXLY, NBOXLZ 
946: LOGICAL, INTENT(IN) :: NBULKT 
947:  
948: DOUBLE PRECISION BVEC(3) 
949: INTEGER I, J, K, IND, NDUMMY, NUMSTRUCTS 
950:  
951: BOXLX = NBOXLX 
952: BOXLY = NBOXLY 
953: BOXLZ = NBOXLZ 
954: BOXVEC = (/BOXLX,BOXLY,BOXLZ/) 
955: BULKT = NBULKT 
956:  
957: NCALC   = 0 
958: NLAP    = 0 
959: NQUENCH = 0 
960: NBAD = 0 
961:  
962: ! --------------------------------------------------------------------------- ! 
963: !    allocating memory to arrays 
964: ! --------------------------------------------------------------------------- ! 
965:  
966: NUMSTRUCTS = 1 
967: IF (PERMINVOPT) THEN 
968:     NUMSTRUCTS = 2 
969: ELSE IF (BULKT.AND.OHCELLT) THEN 
970:     NUMSTRUCTS = 48 
971: ENDIF 
972:  
973: CALL REALLOCATEARRAYS(NATOMS, NUMSTRUCTS, BULKT) 
974:  
975: ! --------------------------------------------------------------------------- ! 
976: !    calculate inverse permutation group 
977: ! --------------------------------------------------------------------------- ! 
978:  
979: DO I=1,NATOMS 
980:     INVPERMGROUP(PERMGROUP(I)) = I 
981: END DO 
982:  
983: ! --------------------------------------------------------------------------- ! 
984: !    storing coordinates to module 
985: ! --------------------------------------------------------------------------- ! 
986:  
987: NDUMMY = 0 
988: IF(BULKT) THEN 
989: !    Needed for k-d trees stuff 
990: !    DO I=1,NPERMGROUP 
991: !        DO J=1, NPERMSIZE(I) 
992: !            IND = PERMGROUP(NDUMMY+J) 
993: !            SAVECOORDSB(3*IND-2) = COORDSB(3*IND-2) - BOXLX*ANINT(COORDSB(3*IND-2)/BOXLX) 
994: !            SAVECOORDSB(3*IND-1) = COORDSB(3*IND-1) - BOXLY*ANINT(COORDSB(3*IND-1)/BOXLY) 
995: !            SAVECOORDSB(3 * IND) = COORDSB(3 * IND) - BOXLZ*ANINT(COORDSB(3 * IND)/BOXLZ) 
996: !        ENDDO 
997: !    NDUMMY = NDUMMY + NPERMSIZE(I) 
998: !    ENDDO 
999:     SAVECOORDSB = COORDSB 
1000:     IF(OHCELLT) THEN 
1001:         DO I=1,48 
1002:             CALL OHOPS(COORDSA,SAVECOORDSA(:,I),I,NATOMS) 
1003:         END DO 
1004:     ELSE 
1005:         SAVECOORDSA(:,1) = COORDSA 
1006:     END IF 
1007: ELSE 
1008:     ! Calculate COM 
1009:     DO J=1,NATOMS 
1010:         CMAX=CMAX+COORDSA(3*(J-1)+1) 
1011:         CMAY=CMAY+COORDSA(3*(J-1)+2) 
1012:         CMAZ=CMAZ+COORDSA(3*(J-1)+3) 
1013:     ENDDO 
1014:     CMAX=CMAX/NATOMS; CMAY=CMAY/NATOMS; CMAZ=CMAZ/NATOMS 
1015:     CMBX=0.0D0; CMBY=0.0D0; CMBZ=0.0D0 
1016:     DO J=1,NATOMS 
1017:         CMBX=CMBX+COORDSB(3*(J-1)+1) 
1018:         CMBY=CMBY+COORDSB(3*(J-1)+2) 
1019:         CMBZ=CMBZ+COORDSB(3*(J-1)+3) 
1020:     ENDDO 
1021:     CMBX=CMBX/NATOMS; CMBY=CMBY/NATOMS; CMBZ=CMBZ/NATOMS 
1022:  
1023:     ! Save COM centred coordinates 
1024:     DO I=1,NATOMS 
1025:         SAVECOORDSB(3*I-2) = COORDSB(3*I-2) - CMBX 
1026:         SAVECOORDSB(3*I-1) = COORDSB(3*I-1) - CMBY 
1027:         SAVECOORDSB(3 * I) = COORDSB(3 * I) - CMBZ 
1028:         SAVERB(I) = SQRT(SAVECOORDSB(3*I-2)**2+SAVECOORDSB(3*I-1)**2+ & 
1029:                        & SAVECOORDSB(3 * I)**2) 
1030:     ENDDO 
1031:     DO I=1,NATOMS 
1032:         SAVECOORDSA(3*I-2,1) = COORDSA(3*I-2) - CMAX 
1033:         SAVECOORDSA(3*I-1,1) = COORDSA(3*I-1) - CMAY 
1034:         SAVECOORDSA(3 * I,1) = COORDSA(3 * I) - CMAZ 
1035:         SAVERA(I,1) = SQRT(SAVECOORDSA(3*I-2,1)**2+SAVECOORDSA(3*I-1,1)**2+ & 
1036:                          & SAVECOORDSA(3 * I,1)**2) 
1037:     ENDDO 
1038:     ! Store inverted configuration 
1039:     IF (PERMINVOPT) THEN 
1040:         SAVECOORDSA(:,2) = -SAVECOORDSA(:,1) 
1041:         SAVERA(:,2) = SAVERA(:,1) 
1042:     END IF 
1043: END IF 
1044:  
1045: ! --------------------------------------------------------------------------- ! 
1046: ! Allocate and populate k-d trees, should be a faster way of finding nearest 
1047: ! neighbours, currently isn't... 
1048: ! --------------------------------------------------------------------------- ! 
1049:  
1050: !IF(ALLOCATED(KDTREES)) DEALLOCATE(KDTREES) 
1051: !ALLOCATE(KDTREES(NPERMGROUP)) 
1052: !NDUMMY = 0 
1053: !DO I=1,NPERMGROUP 
1054: !    IF(BULKT) THEN 
1055: !    DO K=0,8 
1056: !        BVEC(1) = BOXLX*LVECS(1,K) 
1057: !        BVEC(2) = BOXLY*LVECS(2,K) 
1058: !        BVEC(3) = BOXLZ*LVECS(3,K) 
1059: !        DO J=1, NPERMSIZE(I) 
1060: !            IND = PERMGROUP(NDUMMY+J) 
1061: !            PERMCOORDSB(1,J+K*NPERMSIZE(I),I) = SAVECOORDSB(3*IND-2) + BVEC(1) 
1062: !            PERMCOORDSB(2,J+K*NPERMSIZE(I),I) = SAVECOORDSB(3*IND-1) + BVEC(2) 
1063: !            PERMCOORDSB(3,J+K*NPERMSIZE(I),I) = SAVECOORDSB(3*IND) + BVEC(3) 
1064: !        ENDDO 
1065: !    ENDDO 
1066: !    KDTREES(I)%TREE => KDTREE2_CREATE(PERMCOORDSB(:,:NPERMSIZE(I)*9,I),NPERMSIZE(I)*9,.true.,.true.) 
1067: !    ELSE 
1068: !        DO J=1, NPERMSIZE(I) 
1069: !            IND = PERMGROUP(NDUMMY+J) 
1070: !            PERMCOORDSB(:,J,I)=COORDSB(3*IND-2:3*IND) - (/CMBX,CMBY,CMBZ/) 
1071: !        ENDDO 
1072: !        KDTREES(I)%TREE => KDTREE2_CREATE(PERMCOORDSB(:,:NPERMSIZE(I),I),NPERMSIZE(I),.true.,.true.) 
1073: !    END IF 
1074: !    NDUMMY = NDUMMY + NPERMSIZE(I) 
1075: !ENDDO 
1076:  
1077: CALL QUEUECLEAR() 
1078:  
1079: END SUBROUTINE INITIALISE 
1080:  
1081: SUBROUTINE SETNATOMS(NEWNATOMS) 
1082: ! Checks if arrays need to be (re)allocated 
1083: IMPLICIT NONE 
1084:  
1085: INTEGER, INTENT(IN) :: NEWNATOMS 
1086:  
1087: NATOMS = NEWNATOMS  ! This sets the value of NATOMS that will be SAVE'd in this module. 
1088: IF(.NOT.(SIZE(PDUMMYA).EQ.(3*NEWNATOMS))) THEN 
1089:     IF(ALLOCATED(PDUMMYA)) THEN 
1090:         DEALLOCATE(PDUMMYA,PDUMMYB,DUMMYA,DUMMYB,XBESTA,XBESTASAVE) 
1091:         DEALLOCATE(NEWPERM, LPERM) 
1092:     ENDIF 
1093:     ALLOCATE(PDUMMYA(3*NEWNATOMS),PDUMMYB(3*NEWNATOMS),DUMMYA(3*NEWNATOMS), & 
1094:     &   DUMMYB(3*NEWNATOMS), XBESTA(3*NEWNATOMS), XBESTASAVE(3*NEWNATOMS)) 
1095:     ALLOCATE(NEWPERM(NEWNATOMS), LPERM(NEWNATOMS)) 
1096: ENDIF 
1097:  
1098: END SUBROUTINE SETNATOMS 
1099:  
1100: SUBROUTINE SETPERM(NEWNATOMS, NEWPERMGROUP, NEWNPERMSIZE) 
1101: ! Not needed for GMIN/OPTIM/PATHSAMPLE 
1102: ! (Re)allocates arrays that define allowed permuations 
1103: IMPLICIT NONE 
1104:  
1105: INTEGER, INTENT(IN) :: NEWNATOMS, NEWPERMGROUP(:), NEWNPERMSIZE(:) 
1106:  
1107: IF(.NOT.SIZE(PERMGROUP).EQ.SIZE(NEWPERMGROUP)) THEN 
1108:     IF(ALLOCATED(PERMGROUP)) THEN 
1109:         DEALLOCATE(PERMGROUP) 
1110:     ENDIF 
1111:     ALLOCATE(PERMGROUP(SIZE(NEWPERMGROUP))) 
1112: ENDIF 
1113:  
1114: NPERMGROUP = SIZE(NEWNPERMSIZE) 
1115: IF(.NOT.SIZE(NPERMSIZE).EQ.SIZE(NEWNPERMSIZE)) THEN 
1116:     IF(ALLOCATED(NPERMSIZE)) THEN 
1117:         DEALLOCATE(NPERMSIZE) 
1118:     ENDIF 
1119:     ALLOCATE(NPERMSIZE(NPERMGROUP)) 
1120: ENDIF 
1121:  
1122: IF(.NOT.SIZE(BESTPERM).EQ.NEWNATOMS) THEN 
1123:     IF(ALLOCATED(BESTPERM)) THEN 
1124:         DEALLOCATE(BESTPERM) 
1125:     ENDIF 
1126:     ALLOCATE(BESTPERM(NEWNATOMS)) 
1127: ENDIF 
1128:  
1129: IF(.NOT.SIZE(NSETS).EQ.(3*NEWNATOMS)) THEN 
1130:     IF(ALLOCATED(NSETS)) THEN 
1131:         DEALLOCATE(NSETS) 
1132:     ENDIF 
1133:     ALLOCATE(NSETS(3*NEWNATOMS)) 
1134: ENDIF 
1135:  
1136: IF(.NOT.SIZE(SETS).EQ.(3*NEWNATOMS*70)) THEN 
1137:     IF(ALLOCATED(SETS)) THEN 
1138:         DEALLOCATE(SETS) 
1139:     ENDIF 
1140:     ALLOCATE(SETS(3*NEWNATOMS,70)) 
1141: ENDIF 
1142:  
1143: CALL SETNATOMS(NEWNATOMS) 
1144:  
1145: NATOMS = NEWNATOMS 
1146: PERMGROUP = NEWPERMGROUP 
1147: NPERMSIZE = NEWNPERMSIZE 
1148: NSETS = 0 
1149:  
1150: END SUBROUTINE SETPERM 
1151:  
1152: SUBROUTINE PAIRDISTS(n, p, q, sx, sy, sz, pbc, cc, kk, maxnei) 
1153:       implicit none 
1154:  
1155: !     Input 
1156: !       n  : System size 
1157: !       p,q: Coordinate vectors (n particles) 
1158: !       s  : Box lengths (or dummy if open B.C.) 
1159: !       pbc: Periodic boundary conditions? 
1160:       integer, intent(in) :: n, maxnei 
1161:       double precision, intent(in) :: p(3*n), q(3*n), sx, sy, sz 
1162:       logical, intent(in) :: pbc 
1163:       double precision s(3) 
1164:  
1165: !     Output 
1166: !       perm: Permutation so that p(i) <--> q(perm(i)) 
1167: !       dist: Minimum attainable distance 
1168: !     We have 
1169:       double precision, intent(out) :: cc(n*maxnei) 
1170:       integer, intent(out) :: kk(n*maxnei) 
1171:       double precision DUMMY 
1172:  
1173: !     Parameters 
1174: !       scale : Precision 
1175: !       maxnei: Maximum number of closest neighbours 
1176:       double precision scale, d, h 
1177:  
1178:       parameter (scale = 1.0d6   ) 
1179: !      parameter (maxnei = 60     ) 
1180:  
1181:       integer*8 first(n+1)!, x(n), y(n) 
1182: !      integer*8 u(n), v(n) 
1183:       integer   m, i, j, k, l, l2, t, a 
1184:       integer*8 n8, sz8 
1185:       integer J1 
1186:  
1187: !     Distance function 
1188:       double precision permdist 
1189:  
1190:       s(1)=sx 
1191:       s(2)=sy 
1192:       s(3)=sz 
1193:       m = maxnei 
1194:       if(n .le. maxnei) m = n 
1195:       sz8 = m*n 
1196:       n8 = n 
1197:  
1198:       do i=0,n 
1199:          first(i+1) = i*m + 1 
1200:       enddo 
1201:  
1202:       if(m .eq. n) then 
1203: !     Compute the full matrix... 
1204:          do i=1,n 
1205:             k = first(i)-1 
1206:             do j=1,n 
1207:                cc(k+j) = permdist(p(3*i-2), q(3*j-2), s, pbc) 
1208:                kk(k+j) = j 
1209: !              write(*,*) i, j, '-->', cc(k+j) 
1210:             enddo 
1211:          enddo 
1212:       else 
1213: !     We need to store the distances of the maxnei closeest neighbors 
1214: !     of each particle. The following builds a heap to keep track of 
1215: !     the maxnei closest neighbours seen so far. It might be more 
1216: !     efficient to use quick-select instead... (This is definitely 
1217: !     true in the limit of infinite systems.) 
1218:         do i=1,n 
1219:            k = first(i)-1 
1220:            do j=1,m 
1221:               cc(k+j) = permdist(p(3*i-2), q(3*j-2), s, pbc) 
1222:               kk(k+j) = j 
1223:               l = j 
1224: 10            if(l .le. 1) goto 11 
1225:               l2 = l/2 
1226:               if(cc(k+l2) .lt. cc(k+l)) then 
1227:                  h = cc(k+l2) 
1228:                  cc(k+l2) = cc(k+l) 
1229:                  cc(k+l) = h 
1230:                  t = kk(k+l2) 
1231:                  kk(k+l2) = kk(k+l) 
1232:                  kk(k+l) = t 
1233:                  l = l2 
1234:                  goto 10 
1235:               endif 
1236: 11         enddo 
1237:  
1238:            do j=m+1,n 
1239:               d = permdist(p(3*i-2), q(3*j-2), s, pbc) 
1240:               if(d .lt. cc(k+1)) then 
1241:                  cc(k+1) = d 
1242:                  kk(k+1) = j 
1243:                  l = 1 
1244: 20               l2 = 2*l 
1245:                  if(l2+1 .gt. m) goto 21 
1246:                  if(cc(k+l2+1) .gt. cc(k+l2)) then 
1247:                     a = k+l2+1 
1248:                  else 
1249:                     a = k+l2 
1250:                  endif 
1251:                  if(cc(a) .gt. cc(k+l)) then 
1252:                     h = cc(a) 
1253:                     cc(a) = cc(k+l) 
1254:                     cc(k+l) = h 
1255:                     t = kk(a) 
1256:                     kk(a) = kk(k+l) 
1257:                     kk(k+l) = t 
1258:                     l = a-k 
1259:                     goto 20 
1260:                  endif 
1261: 21               if (l2 .le. m) THEN ! split IF statements to avoid a segmentation fault 
1262:                     IF (cc(k+l2) .gt. cc(k+l)) then 
1263:                        h = cc(k+l2) 
1264:                        cc(k+l2) = cc(k+l) 
1265:                        cc(k+l) = h 
1266:                        t = kk(k+l2) 
1267:                        kk(k+l2) = kk(k+l) 
1268:                        kk(k+l) = t 
1269:                     ENDIF 
1270:                  endif 
1271:               endif 
1272:            enddo 
1273:         enddo 
1274:       ENDIF 
1275:  
1276: END SUBROUTINE PAIRDISTS 
1277:  
1278: SUBROUTINE TRANSFORM(NEWCOORDSA, NATOMS, VECTOR, IDNUM) 
1279:  
1280: IMPLICIT NONE 
1281: INTEGER, INTENT(IN) :: NATOMS, IDNUM 
1282: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3) 
1283:  
1284: DOUBLE PRECISION, INTENT(OUT) :: NEWCOORDSA(3*NATOMS) 
1285:  
1286: INTEGER I 
1287:  
1288: IF(BULKT) THEN 
1289:     DO I=1,NATOMS 
1290:         NEWCOORDSA(3*I-2) = SAVECOORDSA(3*I-2,IDNUM) - VECTOR(1) 
1291:         NEWCOORDSA(3*I-1) = SAVECOORDSA(3*I-1,IDNUM) - VECTOR(2) 
1292:         NEWCOORDSA(3*I  ) = SAVECOORDSA(3*I  ,IDNUM) - VECTOR(3) 
1293:     ENDDO 
1294:     ! NEWMINDIST superimposes COMs of coordinates 
1295: !    NEWCOORDSA(3*I-2) = NEWCOORDSA(3*I-2) + & 
1296: ! & BOXLX*NINT((SAVECOORDSB(3*I-2)-NEWCOORDSA(3*I-2))/BOXLX) 
1297: !    NEWCOORDSA(3*I-1) = NEWCOORDSA(3*I-1) + & 
1298: ! & BOXLY*NINT((SAVECOORDSB(3*I-1)-NEWCOORDSA(3*I-1))/BOXLY) 
1299: !    NEWCOORDSA(3*I  ) = NEWCOORDSA(3*I  ) + & 
1300: ! & BOXLZ*NINT((SAVECOORDSB(3*I  )-NEWCOORDSA(3*I  ))/BOXLZ) 
1301: ELSE 
1302:     CALL ANGLEAXIS2MAT(VECTOR, TRMAT) 
1303:     DO I=1,NATOMS 
1304:         NEWCOORDSA(3*I-2:3*I) = MATMUL(TRMAT,SAVECOORDSA(3*I-2:3*I,IDNUM)) 
1305:     ENDDO 
1306: ENDIF 
1307:  
1308: END SUBROUTINE TRANSFORM 
1309:  
1310: SUBROUTINE ANGLEAXIS2MAT(VECTOR,RMAT) 
1311:  
1312: IMPLICIT NONE 
1313: DOUBLE PRECISION, INTENT(IN) :: VECTOR(3) 
1314: DOUBLE PRECISION, INTENT(OUT) :: RMAT(3,3) 
1315:  
1316: DOUBLE PRECISION THETA,X,Y,Z,S,C,C1,XS,YS,ZS,XC,YC,ZC,XYC,YZC,ZXC 
1317:  
1318: THETA = SUM((VECTOR**2))**0.5 
1319:  
1320: IF(THETA.EQ.0.D0) THEN 
1321:     RMAT = RESHAPE((/& 
1322:      & 1.00000000000D0,  0.0D0,  0.0D0,   & 
1323:      & 0.0D0,  1.00000000000D0,  0.0D0,   & 
1324:      & 0.0D0,  0.0D0,  1.00000000000D0/), (/3,3/)) 
1325: ELSE 
1326:     X = VECTOR(1)/THETA; Y = VECTOR(2)/THETA; Z = VECTOR(3)/THETA 
1327:     S = SIN(THETA); C = COS(THETA); C1 = 1.D0 - C 
1328:     XS = X*S; YS = Y*S; ZS = Z*S 
1329:     XC = X*C1; YC = Y*C1; ZC = Z*C1 
1330:     XYC = X*YC; YZC = Y*ZC; ZXC = Z*XC 
1331:  
1332:     RMAT = RESHAPE((/& 
1333:      & x * xC + c, xyC + zs, zxC - ys, & 
1334:      & xyC - zs, y * yC + c, yzC + xs, & 
1335:      & zxC + ys, yzC - xs, z * zC + c/), (/3,3/)) 
1336: END IF 
1337:  
1338: END SUBROUTINE ANGLEAXIS2MAT 
1339:  
1340: SUBROUTINE MAT2ANGLEAXIS(VECTOR, RMAT) 
1341:  
1342: IMPLICIT NONE 
1343: DOUBLE PRECISION, INTENT(OUT) :: VECTOR(3) 
1344: DOUBLE PRECISION, INTENT(IN) :: RMAT(0:2,0:2) 
1345:  
1346: DOUBLE PRECISION TRACE, THETA 
1347:  
1348: TRACE = RMAT(0,0)+RMAT(1,1)+RMAT(2,2) 
1349: THETA = ACOS(0.5D0*TRACE-0.5D0) 
1350: VECTOR = (/RMAT(2,1)-RMAT(1,2),RMAT(0,2)-RMAT(2,0),RMAT(1,0)-RMAT(0,1)/) 
1351: VECTOR = VECTOR * 0.5D0 * THETA / SIN(THETA) 
1352:  
1353: END SUBROUTINE MAT2ANGLEAXIS 
1354:  
1355: SUBROUTINE REALLOCATEARRAYS(NATOMS, NUMSTRUCTS, BULKT) 
1356:  
1357: IMPLICIT NONE 
1358:  
1359: INTEGER, INTENT(IN) :: NATOMS, NUMSTRUCTS 
1360: LOGICAL, INTENT(IN) :: BULKT 
1361:  
1362: IF(ALLOCATED(PERMCOORDSB))  DEALLOCATE(PERMCOORDSB) 
1363: IF(BULKT) THEN 
1364:     ALLOCATE(PERMCOORDSB(3,9*NATOMS,NPERMGROUP)) 
1365: ELSE 
1366:     ALLOCATE(PERMCOORDSB(3,NATOMS,NPERMGROUP)) 
1367: END IF 
1368:  
1369: IF(ALLOCATED(SAVECOORDSB))  DEALLOCATE(SAVECOORDSB,SAVECOORDSA) 
1370: IF(ALLOCATED(SAVERA)) DEALLOCATE(SAVERA,SAVERB,BESTCOORDSA,BESTRMAT,BESTITERS) 
1371: ALLOCATE(SAVECOORDSB(3*NATOMS),SAVECOORDSA(3*NATOMS,NUMSTRUCTS), & 
1372:  & SAVERB(NATOMS),SAVERA(NATOMS,NUMSTRUCTS),BESTCOORDSA(3*NATOMS,NUMSTRUCTS), & 
1373:  & BESTRMAT(3,3,NUMSTRUCTS),BESTITERS(NUMSTRUCTS)) 
1374:  
1375: IF(ALLOCATED(PDUMMYA)) DEALLOCATE(PDUMMYA,PDUMMYB,DUMMYA,DUMMYB,NEWPERM,LPERM) 
1376: IF(ALLOCATED(INVPERMGROUP)) DEALLOCATE(INVPERMGROUP) 
1377: ALLOCATE(PDUMMYA(3*NATOMS),PDUMMYB(3*NATOMS),DUMMYA(3*NATOMS), & 
1378:  & DUMMYB(3*NATOMS),NEWPERM(NATOMS),LPERM(NATOMS),INVPERMGROUP(NATOMS)) 
1379:  
1380: IF(ALLOCATED(DUMMYDISTS)) DEALLOCATE(DUMMYDISTS,DUMMYNEARDISTS,PDUMMYND, & 
1381:  & DUMMYDISPS,DUMMYIDX,DINVIDX,DUMMYNEARIDX,DUMMYLDISTS,DUMMYNEARLDISTS, & 
1382:  & DUMMYLDISTS2,DUMMYDOTDISP) 
1383: ALLOCATE(DUMMYDISTS(PMAXNEI*NATOMS,NPERMGROUP),DUMMYNEARDISTS(NATOMS), & 
1384:  & PDUMMYND(NATOMS),DUMMYIDX(PMAXNEI*NATOMS,NPERMGROUP),DUMMYNEARIDX(NATOMS), & 
1385:  & DINVIDX(NATOMS*NATOMS,NPERMGROUP),DUMMYLDISTS(PMAXNEI*NATOMS,NPERMGROUP), & 
1386:  & DUMMYNEARLDISTS(NATOMS),DUMMYLDISTS2(PMAXNEI*NATOMS,NPERMGROUP), & 
1387:  & DUMMYDISPS(3,NATOMS*PMAXNEI,NPERMGROUP),DUMMYDOTDISP(4,NATOMS*PMAXNEI,NPERMGROUP)) 
1388:  
1389: END SUBROUTINE REALLOCATEARRAYS 
1390:  
1391: SUBROUTINE SETCLUSTER(INVERT) 
1392:  
1393: USE COMMONS, ONLY : MYUNIT,NFREEZE,GEOMDIFFTOL,ORBITTOL,FREEZE,PULLT,TWOD,  & 
1394:     &   EFIELDT,AMBERT,QCIAMBERT,AMBER12T,CHRMMT,STOCKT,CSMT,PERMDIST,      & 
1395:     &   LOCALPERMDIST,LPERMDIST,OHCELLT,QCIPERMCHECK,PERMOPT,PERMINVOPT,    & 
1396:     &   NOINVERSION,GTHOMSONT,MKTRAPT,MULLERBROWNT,RIGID,OHCELLT 
1397:  
1398: IMPLICIT NONE 
1399:  
1400: LOGICAL, INTENT(IN) :: INVERT 
1401:  
1402: MYUNIT = 6 
1403: NFREEZE = 0 
1404: GEOMDIFFTOL = 0.5D0 
1405: ORBITTOL = 1.0D-3 
1406:  
1407: FREEZE = .FALSE. 
1408: PULLT = .FALSE. 
1409: TWOD = .FALSE. 
1410: EFIELDT = .FALSE. 
1411: AMBERT = .FALSE. 
1412: QCIAMBERT = .FALSE. 
1413: AMBER12T = .FALSE. 
1414: CHRMMT = .FALSE. 
1415: STOCKT = .FALSE. 
1416: CSMT = .FALSE. 
1417: PERMDIST = .TRUE. 
1418: LOCALPERMDIST = .FALSE. 
1419: LPERMDIST = .FALSE. 
1420: QCIPERMCHECK = .FALSE. 
1421: PERMOPT = .TRUE. 
1422: PERMINVOPT = INVERT 
1423: NOINVERSION = .FALSE. 
1424: GTHOMSONT = .FALSE. 
1425: MKTRAPT = .FALSE. 
1426: MULLERBROWNT = .FALSE. 
1427: RIGID = .FALSE. 
1428: OHCELLT = .FALSE. 
1429:  
1430: END SUBROUTINE SETCLUSTER 
1431:  
1432: SUBROUTINE SETBULK(INVERT) 
1433:  
1434: USE COMMONS, ONLY : MYUNIT,NFREEZE,GEOMDIFFTOL,ORBITTOL,FREEZE,PULLT,TWOD,  & 
1435:     &   EFIELDT,AMBERT,QCIAMBERT,AMBER12T,CHRMMT,STOCKT,CSMT,PERMDIST,      & 
1436:     &   LOCALPERMDIST,LPERMDIST,OHCELLT,QCIPERMCHECK,PERMOPT,PERMINVOPT,    & 
1437:     &   NOINVERSION,GTHOMSONT,MKTRAPT,MULLERBROWNT,RIGID,OHCELLT 
1438:  
1439: IMPLICIT NONE 
1440:  
1441: LOGICAL, INTENT(IN) :: INVERT 
1442:  
1443: MYUNIT = 6 
1444: NFREEZE = 0 
1445: GEOMDIFFTOL = 0.5D0 
1446: ORBITTOL = 1.0D-3 
1447:  
1448: FREEZE = .FALSE. 
1449: PULLT = .FALSE. 
1450: TWOD = .FALSE. 
1451: EFIELDT = .FALSE. 
1452: AMBERT = .FALSE. 
1453: QCIAMBERT = .FALSE. 
1454: AMBER12T = .FALSE. 
1455: CHRMMT = .FALSE. 
1456: STOCKT = .FALSE. 
1457: CSMT = .FALSE. 
1458: PERMDIST = .FALSE. 
1459: LOCALPERMDIST = .FALSE. 
1460: LPERMDIST = .FALSE. 
1461: QCIPERMCHECK = .FALSE. 
1462: PERMOPT = .FALSE. 
1463: PERMINVOPT = .FALSE. 
1464: NOINVERSION = .FALSE. 
1465: GTHOMSONT = .FALSE. 
1466: MKTRAPT = .FALSE. 
1467: MULLERBROWNT = .FALSE. 
1468: RIGID = .FALSE. 
1469: OHCELLT = INVERT 
1470:  
1471: END SUBROUTINE SETBULK 
1472:  
1473: SUBROUTINE CHECKKEYWORDS() 
1474:  
1475: USE COMMONS, ONLY : MYUNIT,NFREEZE,GEOMDIFFTOL,ORBITTOL,FREEZE,PULLT,TWOD,  & 
1476:     &   EFIELDT,AMBERT,QCIAMBERT,AMBER12T,CHRMMT,STOCKT,CSMT,PERMDIST,      & 
1477:     &   LOCALPERMDIST,LPERMDIST,OHCELLT,QCIPERMCHECK,PERMOPT,PERMINVOPT,    & 
1478:     &   NOINVERSION,GTHOMSONT,MKTRAPT,MULLERBROWNT,RIGID,OHCELLT 
1479:  
1480: IMPLICIT NONE 
1481:  
1482: IF(STOCKT) THEN 
1483:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with STOCK keyword' 
1484:     STOP 
1485: ENDIF 
1486:  
1487: IF(CSMT) THEN 
1488:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with CSM keyword' 
1489:     STOP 
1490: ENDIF 
1491:  
1492: IF(PULLT) THEN 
1493:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with PULL keyword' 
1494:     STOP 
1495: ENDIF 
1496:  
1497: IF(EFIELDT) THEN 
1498:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with EFIELD keyword' 
1499:     STOP 
1500: ENDIF 
1501:  
1502: IF(RIGID) THEN 
1503:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with RIGID keyword' 
1504:     STOP 
1505: ENDIF 
1506:  
1507: IF(QCIPERMCHECK) THEN 
1508:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with QCIPERMCHECK keyword' 
1509:     STOP 
1510: ENDIF 
1511:  
1512: IF(QCIAMBERT) THEN 
1513:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with QCIAMBER keyword' 
1514:     STOP 
1515: ENDIF 
1516:  
1517: IF(GTHOMSONT) THEN 
1518:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with GTHOMSON keyword' 
1519:     STOP 
1520: ENDIF 
1521:  
1522: IF(MKTRAPT) THEN 
1523:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with MKTRAP keyword' 
1524:     STOP 
1525: ENDIF 
1526:  
1527: IF(TWOD) THEN 
1528:     WRITE(*,'(A)') 'ERROR - branch and bound not compatible with TWOD keyword' 
1529:     STOP 
1530: ENDIF 
1531:  
1532: END SUBROUTINE CHECKKEYWORDS 
1533:  
1534: END MODULE 
1535:  
1536: !INCLUDE "bulkmindist.f90" 
1537: !INCLUDE "minpermdist.f90" 
1538: !INCLUDE "newmindist.f90" 
1539: !INCLUDE "minperm.f90" 
1540: !INCLUDE "orient.f90" 


r33305/CMakeLists.txt 2017-09-13 18:30:18.998058264 +0100 r33304/CMakeLists.txt 2017-09-13 18:30:22.366103025 +0100
109:                 ${DUMMY_TESTING} 109:                 ${DUMMY_TESTING} 
110:                 ${DUMMY_OPEP}110:                 ${DUMMY_OPEP}
111:                 ${DUMMY_OPTIM} 111:                 ${DUMMY_OPTIM} 
112:                 ${DUMMY_QUIP} )112:                 ${DUMMY_QUIP} )
113: set(DUMMY_CPP_FLAGS "DUMMY_AMBER12;DUMMY_CUDA")113: set(DUMMY_CPP_FLAGS "DUMMY_AMBER12;DUMMY_CUDA")
114: 114: 
115: # Glob all the sources115: # Glob all the sources
116: file(GLOB GMIN_LIB_SOURCES *.f116: file(GLOB GMIN_LIB_SOURCES *.f
117:                            *.f90117:                            *.f90
118:                            *.F118:                            *.F
119:                            *.F90 119:                            *.F90 )
120:                            ALIGN/*.f90 )120:                          #                           ALIGN/*.f90 )
121: 121: 
122: file(GLOB NOT_GMIN_SOURCES myblas.f122: file(GLOB NOT_GMIN_SOURCES myblas.f
123:                            mylapack.f123:                            mylapack.f
124:                            gmin_quip_wrapper.f90124:                            gmin_quip_wrapper.f90
125:                            # These files are generated later125:                            # These files are generated later
126:                            display_version.f90126:                            display_version.f90
127:                            porfuncs.f90 )127:                            porfuncs.f90 )
128: 128: 
129: # Due to a compiler bug in ifort 13.1.3, we can't use -O3 for genrigid.f90129: # Due to a compiler bug in ifort 13.1.3, we can't use -O3 for genrigid.f90
130: # Investigations continue...130: # Investigations continue...


r33305/commons.f90 2017-09-13 18:30:19.222061236 +0100 r33304/commons.f90 2017-09-13 18:30:22.610106266 +0100
 34:      &        BINARY_EXAB_FRQ, NRESMIN, USERES, EXEQ, NONEDAPBC, STRUC, CHEMSHIFTITER, GRIDSIZE, MFETRUNS, BESTINVERT, GCNATOMS, & 34:      &        BINARY_EXAB_FRQ, NRESMIN, USERES, EXEQ, NONEDAPBC, STRUC, CHEMSHIFTITER, GRIDSIZE, MFETRUNS, BESTINVERT, GCNATOMS, &
 35:      &        GCINT, GCRELAX, MTARGETS, & 35:      &        GCINT, GCRELAX, MTARGETS, &
 36:      &        INTCONSEP, INTREPSEP, NCONSTRAINTON, CPREPSEP, CPCONSEP, NCONGEOM, & 36:      &        INTCONSEP, INTREPSEP, NCONSTRAINTON, CPREPSEP, CPCONSEP, NCONGEOM, &
 37:      &        NCPREPULSIVE, NCPCONSTRAINT, MAXCONUSE, INTCONSTEPS, INTRELSTEPS, INTSTEPS1, INTLJSTEPS, & 37:      &        NCPREPULSIVE, NCPCONSTRAINT, MAXCONUSE, INTCONSTEPS, INTRELSTEPS, INTSTEPS1, INTLJSTEPS, &
 38:      &        NTRAPPOW, MAXINTIMAGE, CHECKREPINTERVAL, INTFREEZEMIN, INTNTRIESMAX, INTIMAGEINCR, & 38:      &        NTRAPPOW, MAXINTIMAGE, CHECKREPINTERVAL, INTFREEZEMIN, INTNTRIESMAX, INTIMAGEINCR, &
 39:      &        NCONSTRAINTFIX, INTIMAGECHECK, NREPULSIVEFIX, INTIMAGE, NREPULSIVE, & 39:      &        NCONSTRAINTFIX, INTIMAGECHECK, NREPULSIVEFIX, INTIMAGE, NREPULSIVE, &
 40:      &        NNREPULSIVE, NCONSTRAINT, INTMUPDATE, DUMPINTEOSFREQ, DUMPINTXYZFREQ, & 40:      &        NNREPULSIVE, NCONSTRAINT, INTMUPDATE, DUMPINTEOSFREQ, DUMPINTXYZFREQ, &
 41:      &        LOCALPERMNEIGH, LOCALPERMMAXSEP, MAXNACTIVE, QCIPERMCHECKINT, & 41:      &        LOCALPERMNEIGH, LOCALPERMMAXSEP, MAXNACTIVE, QCIPERMCHECKINT, &
 42:      &        MLPIN, MLPSTART, MLPOUT, MLPHIDDEN, MLPDATA, NMLP, DJWRBID, NHEXAMERS, QCIADDREP, QCIBONDS, QCISECOND, MQUNIT, & 42:      &        MLPIN, MLPSTART, MLPOUT, MLPHIDDEN, MLPDATA, NMLP, DJWRBID, NHEXAMERS, QCIADDREP, QCIBONDS, QCISECOND, MQUNIT, &
 43:      &        MLQIN, MLQSTART, MLQOUT, MLQDATA, NMLQ, NADDTARGET, NUMNN, SQNM_HISTMAX, SQNM_DEBUGRUN, SQNM_DEBUGLEVEL, & 43:      &        MLQIN, MLQSTART, MLQOUT, MLQDATA, NMLQ, NADDTARGET, NUMNN, SQNM_HISTMAX, SQNM_DEBUGRUN, SQNM_DEBUGLEVEL, &
 44:      &        SQNM_WRITEMAX, NEWALDREAL(3), NEWALDRECIP(3), EWALDN, MLPNEIGH, BOXSTEPFREQ, NDISPLACEMENTS, NROTATIONS, MAX_ANGMOM, & 44:      &        SQNM_WRITEMAX, NEWALDREAL(3), NEWALDRECIP(3), EWALDN, MLPNEIGH, BOXSTEPFREQ
 45:      &        BNB_NSTEPS 
 46:  
 47:       DOUBLE PRECISION RHO, GAMMA, SIG, SCEPS, SCC, TOLB, T12FAC, XMOVERENORM, RESIZE, QTSALLIS, & 45:       DOUBLE PRECISION RHO, GAMMA, SIG, SCEPS, SCC, TOLB, T12FAC, XMOVERENORM, RESIZE, QTSALLIS, &
 48:      &                 CQMAX, RADIUS, BQMAX,  MAXBFGS, DECAYPARAM, SYMTOL1, SYMTOL2, SYMTOL3, SYMTOL4, SYMTOL5, PGSYMTOLS(3),& 46:      &                 CQMAX, RADIUS, BQMAX,  MAXBFGS, DECAYPARAM, SYMTOL1, SYMTOL2, SYMTOL3, SYMTOL4, SYMTOL5, PGSYMTOLS(3),&
 49:      &                 ECONV, TOLD, TOLE, SYMREM(120,3,3), GMAX, CUTOFF, PCUT, EXPFAC, EXPD, CENTX, CENTY, CENTZ, & 47:      &                 ECONV, TOLD, TOLE, SYMREM(120,3,3), GMAX, CUTOFF, PCUT, EXPFAC, EXPD, CENTX, CENTY, CENTZ, &
 50:      &                 BOXLX, BOXLY, BOXLZ, BOX3D(3), PCUTOFF, SUPSTEP, SQUEEZER, SQUEEZED, COOPCUT, STOCKMU, STOCKLAMBDA, & 48:      &                 BOXLX, BOXLY, BOXLZ, BOX3D(3), PCUTOFF, SUPSTEP, SQUEEZER, SQUEEZED, COOPCUT, STOCKMU, STOCKLAMBDA, &
 51:      &                 TFAC(3), RMS, TEMPS, SACCRAT, CEIG, PNEWJUMP, EAMP, DISTFAC, ODDCHARGE, COULQ, COULSWAP, & 49:      &                 TFAC(3), RMS, TEMPS, SACCRAT, CEIG, PNEWJUMP, EAMP, DISTFAC, ODDCHARGE, COULQ, COULSWAP, &
 52:      &                 COULTEMP, APP, AMM, APM, XQP, XQM, ALPHAP, ALPHAM, ZSTAR, K_COMP, DGUESS, GUIDECUT, EFAC,& 50:      &                 COULTEMP, APP, AMM, APM, XQP, XQM, ALPHAP, ALPHAM, ZSTAR, K_COMP, DGUESS, GUIDECUT, EFAC,&
 53:      &                 TRENORM, HISTMIN, HISTMAX, HISTFAC, EPSSPHERE, FINALCUTOFF, SHELLPROB, RINGROTSCALE, & 51:      &                 TRENORM, HISTMIN, HISTMAX, HISTFAC, EPSSPHERE, FINALCUTOFF, SHELLPROB, RINGROTSCALE, &
 54:      &                 HISTFACMUL, HPERCENT, AVOIDDIST, MAXERISE, MAXEFALL, TSTART, MATDIFF, STICKYSIG, SDTOL, & 52:      &                 HISTFACMUL, HPERCENT, AVOIDDIST, MAXERISE, MAXEFALL, TSTART, MATDIFF, STICKYSIG, SDTOL, &
 55:      &                 MinimalTemperature, MaximalTemperature, SwapProb, hdistconstraint, COREFRAC, TSTAR, & 53:      &                 MinimalTemperature, MaximalTemperature, SwapProb, hdistconstraint, COREFRAC, TSTAR, &
 56:      &                 RK_R, RK_THETA,ARMA,ARMB, ExtrapolationPercent, lnHarmFreq, PTEMIN, PTEMAX, PTTMIN, PTTMAX, EXCHPROB, & 54:      &                 RK_R, RK_THETA,ARMA,ARMB, ExtrapolationPercent, lnHarmFreq, PTEMIN, PTEMAX, PTTMIN, PTTMAX, EXCHPROB, &
 57:      &                 PTSTEPS, NEQUIL, NQUENCH, COLDFUSIONLIMIT, NEWRES_TEMP, MINOMEGA, LJSIGMA, LJEPSILON, TAUMAX, & 55:      &                 PTSTEPS, NEQUIL, NQUENCH, COLDFUSIONLIMIT, NEWRES_TEMP, MINOMEGA, LJSIGMA, LJEPSILON, TAUMAX, &
 58:      &                 TAUMAXFULL, CPFACTORSG, CPFACTORFG, VGWTOL, ABTHRESH, ACTHRESH, CSMPMAT(3,3), & 56:      &                 TAUMAXFULL, CPFACTORSG, CPFACTORFG, VGWTOL, ABTHRESH, ACTHRESH, CSMPMAT(3,3), &
 59:      &                 RADIUS_CONTAINER, HYDROPHOBIC, RESTRICTREGIONX0, RESTRICTREGIONY0, RESTRICTREGIONZ0, & 57:      &                 RADIUS_CONTAINER, HYDROPHOBIC, RESTRICTREGIONX0, RESTRICTREGIONY0, RESTRICTREGIONZ0, &
 60:      &                 RESTRICTREGIONRADIUS, HARMONICSTR, DUMPUNIQUEEPREV, DUMPUNIQUEEMARKOV, FREEZESAVEE, & 58:      &                 RESTRICTREGIONRADIUS, HARMONICSTR, DUMPUNIQUEEPREV, DUMPUNIQUEEMARKOV, FREEZESAVEE, &
 61:      &                 TBPMIN, TBPSTEP, TBPHF, TBPCF, TBPINCR, SHIFTV, GEOMDIFFTOL, LJATTOC, GCMU, HESS_EIGEN_TOL, & 59:      &                 TBPMIN, TBPSTEP, TBPHF, TBPCF, TBPINCR, SHIFTV, GEOMDIFFTOL, LJATTOC, GCMU, HESS_EIGEN_TOL, &
 62:      &                 SRATIO, TRATIO, EXCHINT, DDMCUT, SUMTEMP, SUMSTEP, SUMOSTEP, EXPANDFACTOR, ROTATEFACTOR, EPSRIGID, & 60:      &                 SRATIO, TRATIO, EXCHINT, DDMCUT, SUMTEMP, SUMSTEP, SUMOSTEP, EXPANDFACTOR, ROTATEFACTOR, EPSRIGID, &
 63:      &                 CONTOURBOUNDS(3,2), KCOMP_RIGID, RIGIDCOMDIST, PALPHA, PBETA, PGAMMA, LAT(3,3), MFETPCTL, MFETTRGT, & 61:      &                 CONTOURBOUNDS(3,2), KCOMP_RIGID, RIGIDCOMDIST, PALPHA, PBETA, PGAMMA, LAT(3,3), MFETPCTL, MFETTRGT, &
 64:      &                 QUIPEQDIST, EWALDALPHA, EWALDREALC, EWALDRECIPC, RSPEED, KERNELWIDTH, & 62:      &                 QUIPEQDIST, EWALDALPHA, EWALDREALC, EWALDRECIPC, RSPEED, &
 65:  63: 
 66: !   parameters for anisotropic potentials 64: !   parameters for anisotropic potentials
 67: ! 65: !
 68: !    DC430 > 66: !    DC430 >
 69:      &                 CAPEPS2, CAPRAD, CAPRHO, CAPHEIGHT1, CAPHEIGHT2, & 67:      &                 CAPEPS2, CAPRAD, CAPRHO, CAPHEIGHT1, CAPHEIGHT2, &
 70:      &                 EPSR, GBKAPPA, GBKAPPRM, GBMU,GBNU, GBSIGNOT, GBEPSNOT, GBCHI, GBCHIPRM, & 68:      &                 EPSR, GBKAPPA, GBKAPPRM, GBMU,GBNU, GBSIGNOT, GBEPSNOT, GBCHI, GBCHIPRM, &
 71:      &                 SIGNOT, EPSNOT, SIGMAF, INVKAP, ESA(3), LPRSQ, LSQDFR, GBDPMU, GBDPEPS, GBDPFCT, & 69:      &                 SIGNOT, EPSNOT, SIGMAF, INVKAP, ESA(3), LPRSQ, LSQDFR, GBDPMU, GBDPEPS, GBDPFCT, &
 72:      &                 PYSIGNOT, PYEPSNOT, PYA1(3), PYA2(3), PYDPMU, PYDPEPS, PYDPFCT, PYGRAVITYC1, PYGRAVITYC2, & 70:      &                 PYSIGNOT, PYEPSNOT, PYA1(3), PYA2(3), PYDPMU, PYDPEPS, PYDPFCT, PYGRAVITYC1, PYGRAVITYC2, &
 73:      &                 LWRCUT, LWCNSTA, LWCNSTB, LWRCUTSQ, LWRCUT2SQ, DELRC, PAPALP, PAPS, PAPCD, PAPEPS, PAPANG1, PAPANG2, & 71:      &                 LWRCUT, LWCNSTA, LWCNSTB, LWRCUTSQ, LWRCUT2SQ, DELRC, PAPALP, PAPS, PAPCD, PAPEPS, PAPANG1, PAPANG2, &
 74:      &                 DBEPSBB, DBEPSAB, DBSIGBB, DBSIGAB, DBPMU, EFIELD, YKAPPA, YEPS, GEMRC, MREQ, HSEFF, BEPS, & 72:      &                 DBEPSBB, DBEPSAB, DBSIGBB, DBSIGAB, DBPMU, EFIELD, YKAPPA, YEPS, GEMRC, MREQ, HSEFF, BEPS, &
118:      &        PTRANDOM, PTINTERVAL, PTSINGLE, PTSETS, CHEMSHIFT, CHEMSHIFT2, CSH, DEBUGss2029, UNIFORMMOVE, RANSEEDT, &116:      &        PTRANDOM, PTINTERVAL, PTSINGLE, PTSETS, CHEMSHIFT, CHEMSHIFT2, CSH, DEBUGss2029, UNIFORMMOVE, RANSEEDT, &
119:      &        TTM3T, NOINVERSION, RIGIDCONTOURT, UPDATERIGIDREFT, HYBRIDMINT, COMPRESSRIGIDT, MWFILMT, &117:      &        TTM3T, NOINVERSION, RIGIDCONTOURT, UPDATERIGIDREFT, HYBRIDMINT, COMPRESSRIGIDT, MWFILMT, &
120:      &        SUPPRESST, MFETT, POLIRT, QUIPT, SWPOTT, MWPOTT, REPMATCHT, GLJT, MLJT, READMASST, SPECMASST, NEWTSALLIST, &118:      &        SUPPRESST, MFETT, POLIRT, QUIPT, SWPOTT, MWPOTT, REPMATCHT, GLJT, MLJT, READMASST, SPECMASST, NEWTSALLIST, &
121:      &        PHI4MODELT, CUDAT, CUDATIMET, AMBER12T, ENERGY_DECOMPT, NEWMOVEST, DUMPMINT, MBPOLT, MOLECULART, GCBHT, SEMIGRAND_MUT, USEROT, &119:      &        PHI4MODELT, CUDAT, CUDATIMET, AMBER12T, ENERGY_DECOMPT, NEWMOVEST, DUMPMINT, MBPOLT, MOLECULART, GCBHT, SEMIGRAND_MUT, USEROT, &
122:      &        SAVEMULTIMINONLY, GRADPROBLEMT, INTLJT, CONDATT, QCIPERMCHECK, RIGIDMBPOLT, &120:      &        SAVEMULTIMINONLY, GRADPROBLEMT, INTLJT, CONDATT, QCIPERMCHECK, RIGIDMBPOLT, &
123:      &        INTCONSTRAINTT, INTFREEZET, CHECKCONINT, CONCUTABST, CONCUTFRACT, INTERPCOSTFUNCTION, &121:      &        INTCONSTRAINTT, INTFREEZET, CHECKCONINT, CONCUTABST, CONCUTFRACT, INTERPCOSTFUNCTION, &
124:      &        RBAAT, FREEZENODEST, DUMPINTEOS, DUMPINTXYZ, QCIPOTT, QCIPOT2T, INTSPRINGACTIVET, LPERMDIST, LOCALPERMDIST, QCIRADSHIFTT, &122:      &        RBAAT, FREEZENODEST, DUMPINTEOS, DUMPINTXYZ, QCIPOTT, QCIPOT2T, INTSPRINGACTIVET, LPERMDIST, LOCALPERMDIST, QCIRADSHIFTT, &
125:      &        MLP3T, MKTRAPT, MLPB3T, MLPB3NEWT, MULTIPOTT, QCIAMBERT, MLPNEWREG, DJWRBT, STEALTHYT, LJADDT, QCINOREPINT, RIGIDMDT, &123:      &        MLP3T, MKTRAPT, MLPB3T, MLPB3NEWT, MULTIPOTT, QCIAMBERT, MLPNEWREG, DJWRBT, STEALTHYT, LJADDT, QCINOREPINT, RIGIDMDT, &
126:      &        DUMPMQT, MLQT, MLQPROB, LJADD2T, MLPVB3T, NOREGBIAS, PYADDT, PYADD2T, LJADD3T, REORDERADDT,  LJADD4T, &124:      &        DUMPMQT, MLQT, MLQPROB, LJADD2T, MLPVB3T, NOREGBIAS, PYADDT, PYADD2T, LJADD3T, REORDERADDT,  LJADD4T, &
127:      &        SQNMT, SQNM_DEBUGT, SQNM_BIOT, BENZRIGIDEWALDT, ORTHO, EWALDT, WATERMETHANET, MLPVB3NNT, CLATHRATET, LJADD3GUIDET, &125:      &        SQNMT, SQNM_DEBUGT, SQNM_BIOT, BENZRIGIDEWALDT, ORTHO, EWALDT, WATERMETHANET, MLPVB3NNT, CLATHRATET, LJADD3GUIDET, &
128:      &        BOXDERIVT, FASTOVERLAPT, BNB_ALIGNT, ALIGNT126:      &        BOXDERIVT
129: !127: !
130:       DOUBLE PRECISION, ALLOCATABLE :: SEMIGRAND_MU(:)128:       DOUBLE PRECISION, ALLOCATABLE :: SEMIGRAND_MU(:)
131:       DOUBLE PRECISION, ALLOCATABLE :: ATMASS(:)129:       DOUBLE PRECISION, ALLOCATABLE :: ATMASS(:)
132:       DOUBLE PRECISION, ALLOCATABLE :: SPECMASS(:)130:       DOUBLE PRECISION, ALLOCATABLE :: SPECMASS(:)
133: 131: 
134: ! dj337: Ewald summation variables132: ! dj337: Ewald summation variables
135:       DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: RERHOARRAY, IMRHOARRAY133:       DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: RERHOARRAY, IMRHOARRAY
136: 134: 
137: ! csw34> FREEZEGROUP variables135: ! csw34> FREEZEGROUP variables
138: !136: !


r33305/DSOFT.f90 2017-09-13 18:30:16.798029018 +0100 r33304/DSOFT.f90 2017-09-13 18:30:20.110073039 +0100
  1: !    SOFT  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/GMIN/source/ALIGN/DSOFT.f90' in revision 33304
  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:  
 34: IMPLICIT NONE 
 35:  
 36: INTEGER*8, SAVE :: BW 
 37: DOUBLE PRECISION, PARAMETER :: PI = 3.141592653589793D0 
 38: DOUBLE PRECISION, SAVE, ALLOCATABLE :: WEIGHTS(:), WIGNERD(:,:,:,:) 
 39:  
 40: CONTAINS 
 41:  
 42: SUBROUTINE SETBANDWIDTH(BANDWIDTH) 
 43:  
 44: IMPLICIT NONE 
 45: INTEGER*8, INTENT(IN) :: BANDWIDTH 
 46:  
 47: ! Check if bandwidth has already been calculated 
 48: IF (BW.NE.BANDWIDTH) THEN 
 49:     IF (ALLOCATED(WEIGHTS)) THEN 
 50:         DEALLOCATE(WEIGHTS) 
 51:     ENDIF 
 52:     IF (ALLOCATED(WIGNERD)) THEN 
 53:         DEALLOCATE(WIGNERD) 
 54:     ENDIF 
 55:     ALLOCATE(WEIGHTS(2*BANDWIDTH)) 
 56:     ALLOCATE(WIGNERD(2*BANDWIDTH,BANDWIDTH,2*BANDWIDTH-1,2*BANDWIDTH-1)) 
 57:     CALL MAKEWEIGHTS(BANDWIDTH) 
 58:     CALL CALCWIGNERD(BANDWIDTH) 
 59: ENDIF 
 60:  
 61: BW = BANDWIDTH 
 62:  
 63: END SUBROUTINE SETBANDWIDTH 
 64:  
 65: SUBROUTINE MAKEWEIGHTS(BANDWIDTH) 
 66:  
 67: IMPLICIT NONE 
 68: INTEGER*8, INTENT(IN) :: BANDWIDTH 
 69:  
 70: DOUBLE PRECISION FUDGE, SINJ 
 71: INTEGER*8 J, K 
 72:  
 73: FUDGE = PI / 4 / BANDWIDTH 
 74:  
 75: DO J=1, BANDWIDTH*2 
 76:     WEIGHTS(J) = 0 
 77:     SINJ = 2.D0 * SIN((2*J-1)*FUDGE) / BANDWIDTH   
 78:     DO K=1,BANDWIDTH   
 79:     WEIGHTS(J) = WEIGHTS(J) + SINJ * SIN((2*J-1)*(2*K-1)*FUDGE) / (2*K - 1)  
 80:     ENDDO 
 81: ENDDO 
 82:  
 83: END SUBROUTINE MAKEWEIGHTS 
 84:  
 85: SUBROUTINE RECURRTERMS(J,M1,M2,A,B,C) 
 86:  
 87: ! The Wigner little d elements are calculated with a recurrence relation 
 88: ! This subroutine calculates the appropriate coefficients of the recurrent  
 89: ! relation. For more information see: 
 90: ! 
 91: !    Kostelec, P. J., & Rockmore, D. N. (2008). FFTs on the rotation group.  
 92: !    Journal of Fourier Analysis and Applications, 14(2), 145–179.  
 93: !    http://doi.org/10.1007/s00041-008-9013-5 
 94:  
 95: IMPLICIT NONE 
 96:  
 97: INTEGER*8, INTENT(IN) :: J,M1,M2 
 98: DOUBLE PRECISION, INTENT(OUT) :: A, B, C 
 99:  
100: DOUBLE PRECISION T1,T2,T3,T4,T5,DJ,DM1,DM2 
101:  
102: DJ = REAL(J,8) 
103: DM1 = REAL(M1,8) 
104: DM2 = REAL(M2,8) 
105:  
106: T1 = ((2.D0*DJ +3.D0)/(2.D0*DJ + 1.D0))**0.5D0 
107: T3 = (DJ+1.D0)*(2.D0*DJ+1.D0) 
108: T5 = (((DJ+1.D0)**2-DM1**2)*((DJ+1.D0)**2-DM2**2))**(-0.5) 
109: B = T1*T3*T5 
110:  
111: IF (J.EQ.0) THEN 
112:     A=0.D0 
113:     C=0.D0 
114: ELSE 
115:     T2 = ( (2.D0*DJ +3.D0)/(2.D0*DJ-1.D0) )**0.5D0 * (DJ+1.D0)/DJ 
116:     T4 = ( (DJ**2-DM1**2)*(DJ**2-DM2**2) )**(0.5) 
117:     A = T2*T4*T5 
118:     C = M1*M2 / (DJ*(DJ+1.D0)) 
119: ENDIF 
120:  
121: !WRITE(*,*) J, T1 
122:  
123: END SUBROUTINE RECURRTERMS 
124:  
125: SUBROUTINE CALCWIGNERD(BANDWIDTH) 
126:  
127: ! 
128: ! Calculates normalised Wigner little-d matrix coefficients for euler angles 
129: ! $\beta_k = \frac{\pi(2k+1)}{4 B}, 0\leq k < 2B$ and B = the bandwidth 
130: ! stores result in WIGNERD(k, l, m1, m2) in the SOFT module. 
131: ! 
132: ! Follows method described in: 
133: ! 
134: !    Kostelec, P. J., & Rockmore, D. N. (2008). FFTs on the rotation group.  
135: !    Journal of Fourier Analysis and Applications, 14(2), 145–179.  
136: !    http://doi.org/10.1007/s00041-008-9013-5 
137:  
138: IMPLICIT NONE 
139:  
140: INTEGER*8, INTENT(IN) :: BANDWIDTH 
141:  
142: DOUBLE PRECISION COSB(2*BANDWIDTH+1), COSB2(2*BANDWIDTH+1), SINB2(2*BANDWIDTH+1) 
143: DOUBLE PRECISION SINCOSB2(2*BANDWIDTH+1), SINDIVCOSB2(2*BANDWIDTH+1) 
144: DOUBLE PRECISION, DIMENSION(0:3*BANDWIDTH-1) :: FACTORIALS 
145: DOUBLE PRECISION FACTOR, FUDGE, BETA, A, B, C, JM1(2*BANDWIDTH+1), T1,T2,T3,T4 
146: INTEGER*8 I,J,M1,M2,IND1,IND2,MAXM 
147:  
148: FUDGE = PI / 4 / BANDWIDTH 
149: DO I=1,2*BANDWIDTH 
150:     BETA = FUDGE * (2*I-1) 
151:     COSB(I) = COS(BETA) 
152:     COSB2(I) = COS(BETA/2) 
153:     SINB2(I) = SIN(BETA/2) 
154:     SINCOSB2 = SINB2*COSB2 
155:     SINDIVCOSB2 = SINB2/COSB2 
156: ENDDO  
157:  
158: FACTORIALS(0) = 1.D0 
159: DO I=1, 3*BANDWIDTH-1 
160:     FACTORIALS(I) = I*FACTORIALS(I-1) 
161: ENDDO 
162:  
163: ! Initialise recurrence 
164: WIGNERD(:,:,:,:) = 0.D0 
165: DO M1=-BANDWIDTH-1,BANDWIDTH-1 
166:     IND1 = MODULO(M1, 2*BANDWIDTH-1) + 1 
167:     DO J=ABS(M1), BANDWIDTH-1 
168:         FACTOR = ((2.D0*J+1.D0)*FACTORIALS(2*J)/FACTORIALS(J+M1)/FACTORIALS(J-M1)/2.D0)**0.5 
169:         IND2 = MODULO(-J, 2*BANDWIDTH-1) + 1 
170:         DO I=1,2*BANDWIDTH 
171:         WIGNERD(I,J+1,J+1,IND1)  = FACTOR * COSB2(I)**(J+M1) * (-SINB2(I))**(J-M1)  
172:         WIGNERD(I,J+1,IND2,IND1) = FACTOR * COSB2(I)**(J-M1) * (SINB2(I))**(J+M1) 
173:         WIGNERD(I,J+1,IND1,J+1)  = FACTOR * COSB2(I)**(J+M1) * (SINB2(I))**(J-M1)  
174:         WIGNERD(I,J+1,IND1,IND2) = FACTOR * COSB2(I)**(J-M1) * (-SINB2(I))**(J+M1) 
175:         ENDDO 
176:     ENDDO 
177: ENDDO 
178:  
179: ! Perform recurrence to calculate Wigner Matrix elements 
180: DO M2=-BANDWIDTH-2,BANDWIDTH-2 
181:     IND2 = MODULO(M2, 2*BANDWIDTH-1) + 1 
182:     DO M1=-BANDWIDTH-2,BANDWIDTH-2 
183:         IND1 = MODULO(M1, 2*BANDWIDTH-1) + 1 
184:         MAXM = MAX(ABS(M1),ABS(M2)) 
185:         DO J=MAXM, BANDWIDTH-2 
186:             CALL RECURRTERMS(J,M1,M2,A,B,C) 
187:             DO I=1,2*BANDWIDTH 
188:                 WIGNERD(I,J+2,IND1,IND2) = B * (COSB(I) - C) * WIGNERD(I,J+1,IND1,IND2) 
189:             ENDDO 
190:             IF (J.GT.0) THEN 
191:                 DO I=1,2*BANDWIDTH 
192:                     WIGNERD(I,J+2,IND1,IND2) = WIGNERD(I,J+2,IND1,IND2) - A*WIGNERD(I,J,IND1,IND2)          
193:                 ENDDO 
194:             ENDIF 
195:         ENDDO 
196:     ENDDO 
197: ENDDO 
198:  
199: END SUBROUTINE CALCWIGNERD 
200:  
201:  
202: SUBROUTINE SOFT(INPUT, OUTPUT, BANDWIDTH) 
203:  
204: ! Performs discrete SO3 Fourier Analysis for a real input array for a function 
205: ! defined on SO(3) returns a complex array of the Fourier Coefficients. 
206:  
207: IMPLICIT NONE 
208:  
209: INTEGER*8, INTENT(IN) :: BANDWIDTH 
210: DOUBLE PRECISION, INTENT(IN) :: INPUT(2*BANDWIDTH,2*BANDWIDTH,2*BANDWIDTH) 
211: COMPLEX*16, INTENT(OUT) :: OUTPUT(BANDWIDTH, 2*BANDWIDTH-1, 2*BANDWIDTH-1) 
212:  
213: !INCLUDE "fftw3.f90" 
214: COMPLEX*16 IN1D(2*BANDWIDTH), OUT1D(2*BANDWIDTH), TEMP(2*BANDWIDTH, 2*BANDWIDTH, 2*BANDWIDTH) 
215: INTEGER*8 PLAN, K1,K2,K3,M1,M2,I1,I2,IND1,IND2,J,MAXM 
216:  
217:  
218: CALL SETBANDWIDTH(BANDWIDTH) 
219:  
220: CALL DFFTW_PLAN_DFT_1D(PLAN, (2*BANDWIDTH), IN1D, OUT1D, FFTW_FORWARD, FFTW_ESTIMATE) 
221:  
222: ! Do FFT on axis 1 
223: DO K1=1,2*BANDWIDTH 
224:     DO K2=1,2*BANDWIDTH 
225:         DO K3=1,2*BANDWIDTH 
226:             IN1D(K3) = CMPLX(INPUT(K3,K2,K1),0.D0, 16) 
227:         ENDDO 
228:         CALL DFFTW_EXECUTE_(PLAN, IN1D, OUT1D) 
229:         DO K3=1,2*BANDWIDTH 
230:             TEMP(K3,K2,K1) = OUT1D(K3) 
231:         ENDDO 
232:     ENDDO 
233: ENDDO 
234:  
235: ! Do FFT on axis 3 
236: DO K1=1,2*BANDWIDTH 
237:     DO K2=1,2*BANDWIDTH 
238:         DO K3=1,2*BANDWIDTH 
239:             IN1D(K3) = TEMP(K2,K1,K3) 
240:         ENDDO 
241:         CALL DFFTW_EXECUTE_(PLAN, IN1D, OUT1D) 
242:         DO K3=1,2*BANDWIDTH 
243:             TEMP(K2,K1,K3) = OUT1D(K3)/(2*BANDWIDTH)**2 
244:         ENDDO 
245:     ENDDO 
246: ENDDO 
247:  
248: ! Perform Discrete Wigner Transform 
249: OUTPUT = CMPLX(0.D0,0.D0,8) 
250: DO M2=-BANDWIDTH-1,BANDWIDTH-1 
251:     I2 = MODULO(M2, 2*BANDWIDTH) + 1 
252:     IND2 = MODULO(M2, 2*BANDWIDTH-1) + 1 
253:     DO M1=-BANDWIDTH-1,BANDWIDTH-1 
254:         I1 = MODULO(M1, 2*BANDWIDTH) + 1 
255:         IND1 = MODULO(M1, 2*BANDWIDTH-1) + 1 
256:         MAXM = MAX(ABS(M1),ABS(M2)) 
257:         DO J=MAXM, BANDWIDTH-1 
258:             DO K1=1,2*BANDWIDTH 
259:                 OUTPUT(J+1,IND1,IND2) = OUTPUT(J+1,IND1,IND2) + WIGNERD(K1,J+1,IND1,IND2)*WEIGHTS(K1)*TEMP(I1,K1,I2) 
260:             ENDDO 
261:         ENDDO 
262:     ENDDO 
263: ENDDO 
264:  
265: CALL DFFTW_DESTROY_PLAN_(PLAN) 
266:  
267: END SUBROUTINE SOFT 
268:  
269: SUBROUTINE ISOFT(INPUT, OUTPUT, BANDWIDTH) 
270:  
271: ! Performs SO3 Fourier Synthesis for a complex input array of Fourier Coefficients 
272: ! Generates a complex output array. 
273:  
274: IMPLICIT NONE 
275:  
276: INTEGER*8, INTENT(IN) :: BANDWIDTH 
277: COMPLEX*16, INTENT(IN) :: INPUT(BANDWIDTH, 2*BANDWIDTH-1, 2*BANDWIDTH-1) 
278: COMPLEX*16, INTENT(OUT) :: OUTPUT(2*BANDWIDTH,2*BANDWIDTH,2*BANDWIDTH) 
279:  
280: !INCLUDE "fftw3.f90" 
281: COMPLEX*16 IN1D(2*BANDWIDTH), OUT1D(2*BANDWIDTH), TEMP(2*BANDWIDTH, 2*BANDWIDTH, 2*BANDWIDTH) 
282: INTEGER*8 PLAN, K1,K2,K3,M1,M2,I1,I2,IND1,IND2,J,MAXM 
283:  
284: CALL SETBANDWIDTH(BANDWIDTH) 
285:  
286: CALL DFFTW_PLAN_DFT_1D(PLAN, (2*BANDWIDTH), IN1D, OUT1D, FFTW_BACKWARD, FFTW_ESTIMATE) 
287:  
288: ! Discrete inverse Wigner Transform 
289: TEMP = CMPLX(0.D0,0.D0,8) 
290: DO M2=-BANDWIDTH-1,BANDWIDTH-1 
291:     I2 = MODULO(M2, 2*BANDWIDTH) + 1 
292:     IND2 = MODULO(M2, 2*BANDWIDTH-1) + 1 
293:     DO M1=-BANDWIDTH-1,BANDWIDTH-1 
294:         I1 = MODULO(M1, 2*BANDWIDTH) + 1 
295:         IND1 = MODULO(M1, 2*BANDWIDTH-1) + 1 
296:         MAXM = MAX(ABS(M1),ABS(M2)) 
297:         DO K1=1,2*BANDWIDTH 
298:             DO J=MAXM, BANDWIDTH-1 
299:                 TEMP(I1,K1,I2) = TEMP(I1,K1,I2) + WIGNERD(K1,J+1,IND1,IND2)*INPUT(J+1,IND1,IND2) 
300:             ENDDO 
301:         ENDDO 
302:     ENDDO 
303: ENDDO 
304:  
305: ! Inverse Fourier Transform on axis 3 
306: DO K1=1,2*BANDWIDTH 
307:     DO K2=1,2*BANDWIDTH 
308:         DO K3=1,2*BANDWIDTH 
309:             IN1D(K3) = TEMP(K2,K1,K3) 
310:         ENDDO 
311:         CALL DFFTW_EXECUTE_(PLAN, IN1D, OUT1D) 
312:         DO K3=1,2*BANDWIDTH 
313:             TEMP(K2,K1,K3) = OUT1D(K3) 
314:         ENDDO 
315:     ENDDO 
316: ENDDO 
317:  
318: ! Inverse Fourier Transform on axis 1 
319: DO K1=1,2*BANDWIDTH 
320:     DO K2=1,2*BANDWIDTH 
321:         DO K3=1,2*BANDWIDTH 
322:             IN1D(K3) = TEMP(K3,K2,K1) 
323:         ENDDO 
324:         CALL DFFTW_EXECUTE_(PLAN, IN1D, OUT1D) 
325:         DO K3=1,2*BANDWIDTH 
326:             OUTPUT(K3,K2,K1) = OUT1D(K3)!/(2*BANDWIDTH)**2 
327:         ENDDO 
328:     ENDDO 
329: ENDDO 
330:  
331: CALL DFFTW_DESTROY_PLAN_(PLAN) 
332:  
333: END SUBROUTINE ISOFT 
334:  
335: ! TODO Implement version of these algorithms that take advantage of the symmetries 
336: ! imposed by a real input array. 
337: ! TODO refactor code to avoid use of MODULO arithmetic 
338:  
339: END MODULE DSOFT 
340:  
341:  
342:  
343:  
344:  
345:  
346:  
347:  
348:  
349:  
350:  
351:  
352:  
353:  
354:  
355:  
356:  


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


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


r33305/fastutils.f90 2017-09-13 18:30:18.118046563 +0100 r33304/fastutils.f90 2017-09-13 18:30:21.422090477 +0100
  1: !    FASTOVERLAP  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/GMIN/source/ALIGN/fastutils.f90' in revision 33304
  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: !         FINDBESTPERMUTATION 
 50: !     Peakfinding subroutines: 
 51: !         SETINDEXES 
 52: !         SETFSPACE 
 53: !         GAUSSIAN 
 54: !         FCN 
 55: !         FIT 
 56: !         FINDPEAK 
 57: !         FINDPEAKS 
 58: !     FFT subroutines 
 59: !         FFT3D 
 60: !         IFFT3D 
 61: !         FFT1D 
 62: !         IFFT1D 
 63: !*********************************************************************** 
 64: USE COMMONS, ONLY : PERMGROUP, NPERMSIZE, NPERMGROUP, NATOMS, BESTPERM, NSETS, SETS, MYUNIT 
 65: USE FFTW3 
 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.(SIZE(PDUMMYA).EQ.(3*NEWNATOMS))) THEN 
103:     IF(ALLOCATED(PDUMMYA)) THEN 
104:         DEALLOCATE(PDUMMYA,PDUMMYB,DUMMYA,DUMMYB,XBESTA,XBESTASAVE) 
105:         DEALLOCATE(NEWPERM, LPERM) 
106:     ENDIF 
107:     ALLOCATE(PDUMMYA(3*NEWNATOMS),PDUMMYB(3*NEWNATOMS),DUMMYA(3*NEWNATOMS), & 
108:     &   DUMMYB(3*NEWNATOMS), XBESTA(3*NEWNATOMS), XBESTASAVE(3*NEWNATOMS)) 
109:     ALLOCATE(NEWPERM(NEWNATOMS), LPERM(NEWNATOMS)) 
110:  
111: ENDIF 
112:  
113: END SUBROUTINE SETNATOMS 
114:  
115: SUBROUTINE SETPERM(NEWNATOMS, NEWPERMGROUP, NEWNPERMSIZE) 
116: ! Not needed for GMIN/OPTIM/PATHSAMPLE 
117: ! (Re)allocates arrays that define allowed permuations 
118: IMPLICIT NONE 
119:  
120: INTEGER, INTENT(IN) :: NEWNATOMS, NEWPERMGROUP(:), NEWNPERMSIZE(:) 
121:  
122: IF(.NOT.SIZE(PERMGROUP).EQ.SIZE(NEWPERMGROUP)) THEN 
123:     IF(ALLOCATED(PERMGROUP)) THEN 
124:         DEALLOCATE(PERMGROUP) 
125:     ENDIF 
126:     ALLOCATE(PERMGROUP(SIZE(NEWPERMGROUP))) 
127: ENDIF 
128:  
129: NPERMGROUP = SIZE(NEWNPERMSIZE) 
130: IF(.NOT.SIZE(NPERMSIZE).EQ.SIZE(NEWNPERMSIZE)) THEN 
131:     IF(ALLOCATED(NPERMSIZE)) THEN 
132:         DEALLOCATE(NPERMSIZE) 
133:     ENDIF 
134:     ALLOCATE(NPERMSIZE(NPERMGROUP)) 
135: ENDIF 
136:  
137: IF(.NOT.SIZE(BESTPERM).EQ.NEWNATOMS) THEN 
138:     IF(ALLOCATED(BESTPERM)) THEN 
139:         DEALLOCATE(BESTPERM) 
140:     ENDIF 
141:     ALLOCATE(BESTPERM(NEWNATOMS)) 
142: ENDIF 
143:  
144: IF(.NOT.SIZE(NSETS).EQ.(3*NEWNATOMS)) THEN 
145:     IF(ALLOCATED(NSETS)) THEN 
146:         DEALLOCATE(NSETS) 
147:     ENDIF 
148:     ALLOCATE(NSETS(3*NEWNATOMS)) 
149: ENDIF 
150:  
151: IF(.NOT.SIZE(SETS).EQ.(3*NEWNATOMS*70)) THEN 
152:     IF(ALLOCATED(SETS)) THEN 
153:         DEALLOCATE(SETS) 
154:     ENDIF 
155:     ALLOCATE(SETS(3*NEWNATOMS,70)) 
156: ENDIF 
157:  
158: CALL SETNATOMS(NEWNATOMS) 
159:  
160: NATOMS = NEWNATOMS 
161: PERMGROUP = NEWPERMGROUP 
162: NPERMSIZE = NEWNPERMSIZE 
163: NSETS = 0 
164:  
165: END SUBROUTINE SETPERM 
166:  
167: SUBROUTINE FINDBESTPERMUTATION(NATOMS,COORDSB,COORDSA,BOXLX,BOXLY,BOXLZ,BULKT,SAVEPERM,LDISTANCE,DIST2,WORSTRAD) 
168:  
169: ! Find best permutational alignment of structures COORDSB with COORDSA given 
170: ! LDISTANCE returns the calculated 
171: ! distance^2 between the structures 
172: !  
173: ! Code copied under GNU GPL licence from minpermdist.f90 from GMIN  
174: ! Copyright (C) 1999-2008 David J. Wales 
175: ! 
176: IMPLICIT NONE 
177:  
178: INTEGER, INTENT(IN) :: NATOMS 
179: DOUBLE PRECISION, INTENT(IN) :: COORDSA(3*NATOMS), COORDSB(3*NATOMS), BOXLX,BOXLY,BOXLZ 
180: LOGICAL, INTENT(IN) :: BULKT 
181: INTEGER, INTENT(OUT) :: SAVEPERM(NATOMS) 
182: DOUBLE PRECISION, INTENT(OUT) :: LDISTANCE, DIST2, WORSTRAD 
183:  
184: DOUBLE PRECISION CURRDIST 
185: INTEGER NDUMMY, J, J1, J2, J3, IND1, IND2, PATOMS 
186:  
187: NDUMMY=1 
188: DO J1=1,NATOMS 
189:     NEWPERM(J1)=J1 
190: ENDDO 
191:  
192: CURRDIST = 0.D0 
193: DO J1=1,NPERMGROUP 
194:     PATOMS=INT(NPERMSIZE(J1),4) 
195:     DO J2=1,PATOMS 
196:         IND2 = NEWPERM(PERMGROUP(NDUMMY+J2-1)) 
197:         PDUMMYA(3*J2-2:3*J2)=COORDSA(3*IND2-2:3*IND2) 
198:         PDUMMYB(3*J2-2:3*J2)=COORDSB(3*IND2-2:3*IND2) 
199:     ENDDO 
200:     CALL MINPERM(PATOMS,PDUMMYB,PDUMMYA,BOXLX,BOXLY,BOXLZ,BULKT,LPERM,LDISTANCE,DIST2,WORSTRAD) 
201:     CURRDIST = CURRDIST + LDISTANCE     
202:     SAVEPERM(1:NATOMS)=NEWPERM(1:NATOMS) 
203:     DO J2=1,PATOMS 
204:         SAVEPERM(PERMGROUP(NDUMMY+J2-1))=NEWPERM(PERMGROUP(NDUMMY+LPERM(J2)-1)) 
205:     ENDDO 
206:  
207:     IF (NSETS(J1).GT.0) THEN 
208:         DO J2=1,PATOMS 
209:             DO J3=1,NSETS(J1) 
210:                 SAVEPERM(SETS(PERMGROUP(NDUMMY+J2-1),J3))=SETS(NEWPERM(PERMGROUP(NDUMMY+LPERM(J2)-1)),J3) 
211:             ENDDO 
212:         ENDDO 
213:     ENDIF 
214:     NDUMMY=NDUMMY+NPERMSIZE(J1) 
215:     NEWPERM(1:NATOMS)=SAVEPERM(1:NATOMS) 
216: ENDDO 
217:  
218: LDISTANCE = CURRDIST 
219: DIST2 = SQRT(LDISTANCE) 
220:  
221: END SUBROUTINE FINDBESTPERMUTATION 
222:  
223: SUBROUTINE SETINDEXES(NEWSHAPE) 
224:  
225: ! Helper routine to allocate memory to appropriate arrays needed to perform 
226: ! Levenberg-Marquardt non-linear least-squares curve fitting to find peaks 
227:  
228: IMPLICIT NONE 
229:  
230: INTEGER, INTENT(IN) :: NEWSHAPE(3) 
231:  
232: IF (.NOT.ALL(FSHAPE.EQ.NEWSHAPE)) THEN 
233:     FSHAPE = NEWSHAPE     
234:     IF(ALLOCATED(FSPACE)) THEN 
235:         DEALLOCATE(FSPACE) 
236:     ENDIF 
237:     IF(ALLOCATED(FVEC)) THEN 
238:         DEALLOCATE(FVEC) 
239:     ENDIF 
240:     IF(ALLOCATED(FJAC)) THEN 
241:         DEALLOCATE(FJAC) 
242:     ENDIF 
243:      
244:     ALLOCATE( FSPACE( FSHAPE(1),FSHAPE(2),FSHAPE(3) ) ) 
245:     FSIZE = SIZE(FSPACE) 
246:      
247:     ALLOCATE(FVEC(FSIZE)) 
248:     ALLOCATE(FJAC(11,FSIZE)) 
249: ENDIF 
250:  
251: END SUBROUTINE SETINDEXES 
252:  
253: !*********************************************************************** 
254:  
255: SUBROUTINE SETFSPACE(NEWFSPACE) 
256:  
257: IMPLICIT NONE 
258:  
259: !INTEGER, INTENT(IN) :: NX,NY,NZ 
260: DOUBLE PRECISION, INTENT(IN), DIMENSION(:,:,:) :: NEWFSPACE 
261: !INTEGER NSHAPE(3) 
262:  
263: !NSHAPE=(/NX,NY,NZ/) 
264: CALL SETINDEXES(SHAPE(NEWFSPACE)) 
265:  
266: FSPACE = NEWFSPACE 
267:  
268: END SUBROUTINE SETFSPACE 
269:  
270: !*********************************************************************** 
271:  
272: SUBROUTINE GAUSSIAN(X,NX,NY,NZ,FOUT) 
273:  
274: ! Routine to calculate the values of a 3-D gaussian 
275: ! FOUT(IX, IY, IZ) = A * Exp(-(I-I0)^T SIGMA (I-I0)) 
276: ! I = (/IX, IY, IZ/) 
277: !specified by the parameter vector X: 
278: ! 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) \) 
279:  
280: IMPLICIT NONE 
281:  
282: INTEGER, INTENT(IN) :: NX, NY, NZ 
283: DOUBLE PRECISION, INTENT(IN), DIMENSION(:) :: X 
284: DOUBLE PRECISION, INTENT(OUT) :: FOUT(NX,NY,NZ) 
285:  
286: INTEGER IX,IY,IZ,J 
287: DOUBLE PRECISION SIGMA(3,3), A, MEAN, Y, EXPY, FY, IND0(3), DY(3) 
288:  
289: A = X(1) 
290: MEAN = X(2) 
291: SIGMA(1,1) = X(3) 
292: SIGMA(2,2) = X(4) 
293: SIGMA(3,3) = X(5) 
294: SIGMA(1,2) = X(6) 
295: SIGMA(2,1) = 0.D0!X(6) 
296: SIGMA(2,3) = X(7) 
297: SIGMA(3,2) = 0.D0!X(7) 
298: SIGMA(1,3) = X(8) 
299: SIGMA(3,1) = 0.D0!X(8) 
300: !IND0 = X(9:11) 
301:  
302: DO IZ=1,NZ 
303:     DO IY=1,NY 
304:         DO IX=1,NX 
305:             IND0 = (/IX,IY,IZ/) - X(9:11) 
306:             DO J=1,3 
307:                 DY(J) = SUM(SIGMA(J,:)*IND0) 
308:             ENDDO 
309:             Y = SUM(IND0*DY) 
310:             EXPY = EXP(-Y) 
311:             FOUT(IX,IY,IZ) =  (A*EXPY + MEAN) 
312:         ENDDO 
313:     ENDDO 
314: ENDDO 
315:  
316: END SUBROUTINE GAUSSIAN 
317:  
318: !*********************************************************************** 
319:  
320: SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) 
321:  
322: !  
323: ! subroutine passed to lmder1 to perform least squares regression, minimizing 
324: ! SUM((FOUT - FSPACE)**2) 
325: ! where  FOUT(IX, IY, IZ) = A * Exp(-(I-I0)^T SIGMA (I-I0)) 
326: ! I = (/IX, IY, IZ/) 
327: !specified by the parameter vector X: 
328: ! X = (\A, mean, SIGMA(1,1), SIGMA(2,2), SIGMA(3,3), SIGMA(1,2),SIGMA(2,3),SIGMA(1,3), I0(1), I0(2), I0(3) \) 
329: ! M = SIZE(FSPACE) is the number of observations 
330: ! LDFJAC = N specifies the dimension of the jacobian matrix 
331: ! N = 11 is the number of parameters to optimise 
332: ! If IFLAG=1 then calculates FVEC, the vector of square difference of each observation 
333: ! If IFLAG=2 then calculates FVEC and FJAC, the jacobian maxtrix of FVEC 
334:  
335: IMPLICIT NONE 
336:  
337: INTEGER, INTENT(IN) :: LDFJAC, N, M, IFLAG 
338: DOUBLE PRECISION, INTENT(OUT) :: FJAC(LDFJAC, N), FVEC(M) 
339: DOUBLE PRECISION, INTENT(INOUT) :: X(N) 
340:  
341: DOUBLE PRECISION SIGMA(3,3), A, MEAN, Y, EXPY, FY, DIFF, DY(3), IND0(3) 
342: INTEGER :: I,J,K,IND(3)!,IX,IY,IZ!,S(2)=(/3,1/) 
343:  
344: ! if IFLAG =/= 1/2 then do nothing... 
345: IF(IFLAG.EQ.1 .OR. IFLAG.EQ.2) THEN 
346: A = X(1) 
347: MEAN = X(2) 
348: SIGMA(1,1) = X(3) 
349: SIGMA(2,2) = X(4) 
350: SIGMA(3,3) = X(5) 
351: SIGMA(1,2) = X(6) 
352: SIGMA(2,1) = 0.D0!X(6) 
353: SIGMA(2,3) = X(7) 
354: SIGMA(3,2) = 0.D0!X(7) 
355: SIGMA(1,3) = X(8) 
356: SIGMA(3,1) = 0.D0!X(8) 
357: !IND0 = X(9:11) 
358:  
359: DO I=1,M 
360:     !Some pointer arithmetic to get the 3D index location 
361:     !I miss 0-indexing 
362:     IND(1) = (I-1)/FSHAPE(2)/FSHAPE(3) + 1 
363:     IND(2) = MOD((I-1)/FSHAPE(3), FSHAPE(2)) + 1 
364:     IND(3) = MOD(I-1, FSHAPE(3)) + 1 
365:     IND0 = IND - X(9:11) 
366:     !Y = 0.D0 
367:     DO J=1,3 
368:         DY(J) = SUM(SIGMA(J,:)*IND0) 
369:     ENDDO 
370:     Y = SUM(IND0*DY) 
371:     EXPY = EXP(-Y) 
372:     FY = (A*EXPY + MEAN) 
373:     DIFF = (FY - FSPACE(IND(1),IND(2),IND(3))) 
374:     FVEC(I) = DIFF**2 
375:     IF(IFLAG.EQ.2) THEN 
376:         ! Calculating Jacobian 
377:         FJAC(I,1) = 2 * EXPY * DIFF 
378:         FJAC(I,2) = 2 * DIFF 
379:         FJAC(I,3) = -(IND0(1)*IND0(1))*A*EXPY * DIFF * 2 
380:         FJAC(I,4) = -(IND0(2)*IND0(2))*A*EXPY * DIFF * 2 
381:         FJAC(I,5) = -(IND0(3)*IND0(3))*A*EXPY * DIFF * 2 
382:         FJAC(I,6) = -(IND0(1)*IND0(2))*A*EXPY * DIFF * 2 
383:         FJAC(I,7) = -(IND0(2)*IND0(3))*A*EXPY * DIFF * 2 
384:         FJAC(I,8) = -(IND0(1)*IND0(3))*A*EXPY * DIFF * 2 
385:         FJAC(I,9:11) = 4 * DY * A * EXPY * DIFF 
386:     ENDIF 
387: ENDDO 
388: ENDIF 
389:  
390: END SUBROUTINE FCN 
391:  
392: !*********************************************************************** 
393:  
394: SUBROUTINE FIT(X, NEWFSPACE, NX, NY, NZ, INFO, TOL) 
395:  
396: ! This fits a 3 dimensional gaussian of the form 
397: ! A exp (- (I-I0)T Sigma (I-I0) ) + mean 
398: ! Where I is the 3-D vector of the indexes 
399: ! To the 3 dimensional array specified by FSPACE 
400: ! This uses the Levenberg-Marquardt method.  
401: ! Usage: 
402: ! CALL FIT(X0, FSPACE, INFO, TOL(optional)) 
403: ! X0 = (\A, mean, SIGMA(1,1), SIGMA(2,2), SIGMA(3,3), SIGMA(1,2),SIGMA(2,3),SIGMA(1,3), I0(1), I0(2), I0(3) \) 
404: !INFO is set as follows: 
405: !    0, improper input parameters. 
406: !    1, algorithm estimates that the relative error in the sum of squares 
407: !       is at most TOL. 
408: !    2, algorithm estimates that the relative error between X and the 
409: !       solution is at most TOL. 
410: !    3, conditions for INFO = 1 and INFO = 2 both hold. 
411: !    4, FVEC is orthogonal to the columns of the jacobian to machine precision. 
412: !    5, number of calls to FCN with IFLAG = 1 has reached 100*(N+1). 
413: !    6, TOL is too small.  No further reduction in the sum of squares is 
414: !       possible. 
415: !    7, TOL is too small.  No further improvement in the approximate 
416: !       solution X is possible. 
417:  
418: IMPLICIT NONE 
419:  
420: INTEGER, INTENT(IN) :: NX,NY,NZ 
421: DOUBLE PRECISION, INTENT(IN) :: NEWFSPACE(NX,NY,NZ) 
422: DOUBLE PRECISION, INTENT(IN), OPTIONAL :: TOL 
423: DOUBLE PRECISION, INTENT(INOUT), DIMENSION(:) :: X 
424: INTEGER, INTENT(OUT) :: INFO 
425:  
426: DOUBLE PRECISION USETOL 
427:  
428: IF (PRESENT(TOL)) THEN 
429:     USETOL = TOL 
430: ELSE 
431:     USETOL = DEFAULTTOL 
432: ENDIF 
433:  
434: CALL SETFSPACE(NEWFSPACE) 
435: !Perform Levenberg-Marquardt non-linear least square regression 
436: CALL LMDER1 (FCN, FSIZE, 11, X, FVEC, FJAC, FSIZE, USETOL, INFO) 
437:  
438: END SUBROUTINE FIT 
439:  
440: !*********************************************************************** 
441:  
442: SUBROUTINE FINDPEAK (A, WIDTH, X, INFO, TOL, AMAX) 
443:  
444: ! Finds maximum value of 3D array A Selects the indexes within WIDTH 
445: ! Fits Gaussian to these indexes, then outputs the fit as X 
446:  
447: ! ASSUMES PERIODIC BOUNDARY CONDITIONS 
448:  
449: IMPLICIT NONE 
450:  
451: DOUBLE PRECISION, INTENT(IN), DIMENSION(:,:,:) :: A 
452: DOUBLE PRECISION, INTENT(IN), OPTIONAL :: TOL 
453: INTEGER, INTENT(IN) :: WIDTH 
454: DOUBLE PRECISION, INTENT(OUT) :: X(11) 
455: INTEGER, INTENT(OUT) :: INFO, AMAX(3) 
456:  
457: DOUBLE PRECISION FSPACE(WIDTH*2+1,WIDTH*2+1,WIDTH*2+1) 
458: DOUBLE PRECISION MAXA, MEANA 
459: INTEGER ASHAPE(3),I1,I2,I3,IND(3) !AMAX(3) 
460:  
461: AMAX = MAXLOC(A) 
462: MEANA = SUM(A)/SIZE(A) 
463: MAXA = MAXVAL(A) - MEANA 
464: ! initialise guess for parameter array 
465: X = (/MAXA,MEANA,1.D0,1.D0,1.D0,0.D0,0.D0,0.D0,WIDTH+1.D0,WIDTH+1.D0,WIDTH+1.D0/) 
466: ASHAPE = SHAPE(A) 
467:  
468: ! selecting subarray to fit peak to 
469: DO I3=1,2*WIDTH+1 
470:     DO I2=1,2*WIDTH+1 
471:         DO I1=1,2*WIDTH+1 
472:             ! Ensures periodic boundary conditions 
473:             IND = MODULO(AMAX+(/I1,I2,I3/)-2-WIDTH,ASHAPE) + 1 
474:             FSPACE(I1,I2,I3) = A(IND(1),IND(2),IND(3)) 
475:         ENDDO 
476:     ENDDO 
477: ENDDO 
478:  
479: IF(PRESENT(TOL)) THEN 
480:     CALL FIT(X, FSPACE, WIDTH*2+1, WIDTH*2+1, WIDTH*2+1,INFO, TOL) 
481: ELSE 
482:     CALL FIT(X, FSPACE, WIDTH*2+1, WIDTH*2+1, WIDTH*2+1, INFO) 
483: ENDIF 
484:  
485: END SUBROUTINE FINDPEAK 
486:  
487: !*********************************************************************** 
488:  
489: SUBROUTINE PRINTLMDERERROR(INFO) 
490:  
491: IMPLICIT NONE 
492:  
493: INTEGER, INTENT(IN) :: INFO 
494:  
495: SELECT CASE (INFO) 
496: CASE(0) 
497:     WRITE(MYUNIT,'(A)') "  improper input parameters." 
498: CASE(1) 
499:     WRITE(MYUNIT,'(A)') "  algorithm estimates that the relative error in the sum of squares is at most TOL." 
500: CASE(2) 
501:     WRITE(MYUNIT,'(A)') "  algorithm estimates that the relative error between X and the solution is at most TOL." 
502: CASE(3) 
503:     WRITE(MYUNIT,'(A)') "  conditions for INFO = 1 and INFO = 2 both hold." 
504: CASE(4) 
505:     WRITE(MYUNIT,'(A)') "  FVEC is orthogonal to the columns of the jacobian to machine precision." 
506: CASE(5) 
507:     WRITE(MYUNIT,'(A)') "  number of calls to FCN with IFLAG = 1 has reached 100*(N+1)." 
508: CASE(6) 
509:     WRITE(MYUNIT,'(A)') "  TOL is too small.  No further reduction in the sum of squares is possible." 
510: CASE(7) 
511:     WRITE(MYUNIT,'(A)') "  TOL is too small.  No further improvement in the approximate solution X is possible. " 
512: END SELECT 
513:  
514: END SUBROUTINE PRINTLMDERERROR 
515:  
516: SUBROUTINE FINDPEAKS(FSPACE, PEAKS, AMPLITUDES, NPEAKS, DEBUG) 
517:  
518: ! This finds up to npeaks of a 3D periodic array 
519: ! The locations are returned in peaks as fractional index coordinates 
520: ! Amplitude gives the relative amplitude of each of the peaks 
521: ! NPEAKS gives the actual number of peaks found 
522:  
523: IMPLICIT NONE 
524:  
525: DOUBLE PRECISION, INTENT(IN), DIMENSION(:,:,:) :: FSPACE 
526: INTEGER, INTENT(INOUT) :: NPEAKS 
527: LOGICAL, INTENT(IN) :: DEBUG 
528: !INTEGER, INTENT(IN), OPTIONAL :: WIDTH 
529: DOUBLE PRECISION, INTENT(OUT) :: PEAKS(NPEAKS,3), AMPLITUDES(NPEAKS) 
530:  
531: INTEGER WIDTH, NFOUND, FSHAPE(3), INFO, N, FMAX(3) 
532: DOUBLE PRECISION T, X(11), PEAK(3) 
533: DOUBLE PRECISION, ALLOCATABLE :: FSPACECOPY(:,:,:), GAUSARRAY(:,:,:) 
534:  
535: WIDTH = DEFAULTWIDTH 
536: FSHAPE = SHAPE(FSPACE) 
537:  
538: IF (.NOT.ALL(SHAPE(FSPACECOPY).EQ.FSHAPE)) THEN 
539:     IF(ALLOCATED(FSPACECOPY)) THEN 
540:         DEALLOCATE(FSPACECOPY) 
541:     ENDIF 
542:     IF(ALLOCATED(GAUSARRAY)) THEN 
543:         DEALLOCATE(GAUSARRAY) 
544:     ENDIF 
545:     ALLOCATE(FSPACECOPY(FSHAPE(1),FSHAPE(2),FSHAPE(3)),GAUSARRAY(FSHAPE(1),FSHAPE(2),FSHAPE(3))) 
546: ENDIF 
547:  
548: FSPACECOPY = FSPACE 
549:  
550: NFOUND = 0 
551: DO WHILE(NFOUND.EQ.0) 
552:     DO N=1,NPEAKS 
553:         CALL FINDPEAK(FSPACECOPY, WIDTH, X, INFO, DEFAULTTOL, FMAX) 
554:  
555:         IF(INFO.EQ.0.OR.INFO.EQ.5) THEN 
556:             IF (DEBUG) THEN 
557:                 WRITE(MYUNIT,'(A)') "fastoverlaputils> WARNING - FINDPEAK failed with error:" 
558:                 CALL PRINTLMDERERROR(INFO) 
559:             ENDIF 
560:             EXIT 
561:         ELSE 
562:             IF(INFO.EQ.4.OR.INFO.EQ.6.OR.INFO.EQ.7) THEN 
563:                 IF (DEBUG) THEN 
564:                     WRITE(MYUNIT,'(A)') "fastoverlaputils> WARNING - FINDPEAK ended with message" 
565:                     CALL PRINTLMDERERROR(INFO) 
566:                 ENDIF 
567:             ENDIF 
568: ! Find the location of the peak and subtract this peak from the copy of the data 
569:             NFOUND = NFOUND + 1 
570:             PEAK = (X(9:11) - WIDTH - 1 + FMAX) 
571:             PEAKS(N,:) = PEAK 
572:             AMPLITUDES(N) = X(1) 
573:             X(9:11) = PEAK 
574:             CALL GAUSSIAN(X,FSHAPE(1),FSHAPE(2),FSHAPE(3),GAUSARRAY) 
575:             FSPACECOPY = FSPACECOPY - GAUSARRAY 
576:         ENDIF 
577:     ENDDO 
578:     ! If we've failed to find any peaks, increase the size of the box and start again 
579:     IF (NFOUND.EQ.0) THEN 
580:         WIDTH = WIDTH + 1 
581:         IF (WIDTH.GT.(MINVAL(FSHAPE)/2)) THEN 
582:             WRITE(MYUNIT,'(A)')  "ERROR fastoverlaputils-FINDPEAKS subroutine failed to find any peaks" 
583:             STOP 
584:         ENDIF 
585:     ENDIF 
586: ENDDO 
587:  
588: NPEAKS = NFOUND 
589:  
590: !DEALLOCATE(FSPACECOPY) 
591: !DEALLOCATE(GAUSARRAY) 
592:  
593: END SUBROUTINE FINDPEAKS 
594:  
595: !*********************************************************************** 
596: ! FFT subroutines 
597: !*********************************************************************** 
598:      
599: SUBROUTINE FFT3D(NX, NY, NZ, IN, OUT) 
600: ! calculates forward FFT in 3D 
601: IMPLICIT NONE 
602:  
603: INTEGER, INTENT(IN) :: NX, NY, NZ 
604: COMPLEX*16, INTENT(IN) :: IN(NX, NY, NZ) 
605: COMPLEX*16, INTENT(OUT) :: OUT(NX, NY, NZ) 
606:  
607: !INCLUDE "fftw3.f90" 
608: INTEGER*8 PLAN_FORWARD 
609:  
610: CALL DFFTW_PLAN_DFT_3D_(PLAN_FORWARD, NX, NY, NZ, IN, OUT, FFTW_FORWARD, FFTW_ESTIMATE ) 
611: CALL DFFTW_EXECUTE_(PLAN_FORWARD) 
612: !CALL DFFTW_DESTROY_PLAN(PLAN_FORWARD) 
613:  
614: END SUBROUTINE FFT3D 
615:  
616: !*********************************************************************** 
617:  
618: SUBROUTINE IFFT3D(NX, NY, NZ, IN, OUT) 
619:  
620: ! calculates UNNORMALISED inverse fourier transform so, 
621: ! IN == IFFT3D(NX,NY,NZ, FFT3D(NX,NY,NZ, IN))/(NX*NY*NZ) 
622:  
623: IMPLICIT NONE 
624:  
625: INTEGER, INTENT(IN) :: NX, NY, NZ 
626: COMPLEX*16, INTENT(IN) :: IN(NX, NY, NZ) 
627: COMPLEX*16, INTENT(OUT) :: OUT(NX, NY, NZ) 
628:  
629: !INCLUDE "fftw3.f90" 
630: INTEGER*8 PLAN_BACKWARD 
631:  
632: CALL DFFTW_PLAN_DFT_3D_(PLAN_BACKWARD,NX,NY,NZ,IN,OUT,FFTW_BACKWARD,FFTW_ESTIMATE) 
633: CALL DFFTW_EXECUTE_(PLAN_BACKWARD) 
634: CALL DFFTW_DESTROY_PLAN_(PLAN_BACKWARD) 
635:  
636: END SUBROUTINE IFFT3D 
637:  
638: SUBROUTINE FFT1D(N, IN, OUT) 
639: ! calculates forward FFT in 1D 
640:  
641: IMPLICIT NONE 
642:  
643: INTEGER*4, INTENT(IN) :: N 
644: COMPLEX*16, INTENT(IN) :: IN(N) 
645: COMPLEX*16, INTENT(OUT) :: OUT(N) 
646:  
647: !INCLUDE "fftw3.f90" 
648: INTEGER*8 PLAN_FORWARD 
649:  
650: CALL DFFTW_PLAN_DFT_1D_(PLAN_FORWARD, N, IN, OUT, FFTW_FORWARD, FFTW_ESTIMATE ) 
651: CALL DFFTW_EXECUTE_(PLAN_FORWARD) 
652: CALL DFFTW_DESTROY_PLAN_(PLAN_FORWARD) 
653:  
654: END SUBROUTINE FFT1D 
655:  
656: !*********************************************************************** 
657:  
658: SUBROUTINE IFFT1D(N, IN, OUT) 
659:  
660: ! calculates UNNORMALISED inverse fourier transform so, 
661: ! IN == IFFT1D(N, FFT1D(N, IN))/N 
662:  
663: IMPLICIT NONE 
664:  
665: INTEGER*4, INTENT(IN) :: N 
666: COMPLEX*16, INTENT(IN) :: IN(N) 
667: COMPLEX*16, INTENT(OUT) :: OUT(N) 
668:  
669: !INCLUDE "fftw3.f90" 
670: INTEGER*8 PLAN_BACKWARD 
671:  
672: CALL DFFTW_PLAN_DFT_1D_(PLAN_BACKWARD, N, IN, OUT, FFTW_BACKWARD, FFTW_ESTIMATE ) 
673: CALL DFFTW_EXECUTE_(PLAN_BACKWARD) 
674: CALL DFFTW_DESTROY_PLAN_(PLAN_BACKWARD) 
675:  
676: END SUBROUTINE IFFT1D 
677:  
678: SUBROUTINE ARGSORT(A,A2,ARGS,N) 
679:  
680: IMPLICIT NONE 
681:  
682: INTEGER, INTENT(IN) :: N 
683: DOUBLE PRECISION, INTENT(IN) :: A(N) 
684: INTEGER, INTENT(OUT) :: ARGS(N) 
685: DOUBLE PRECISION, INTENT(OUT) :: A2(N) 
686:  
687: DOUBLE PRECISION TEMP2 
688: INTEGER I, IMIN, TEMP1 
689:  
690: DO I = 1, N 
691:     ARGS(I) = I 
692: END DO 
693: A2 = A 
694:  
695: DO I=1,N-1 
696:     IMIN = MINLOC(A2(I:),1) + I - 1 
697:     IF (IMIN.NE.I) THEN 
698:         TEMP2 = A2(I); A2(I) = A2(IMIN); A2(IMIN) = TEMP2 
699:         TEMP1 = ARGS(I); ARGS(I) = ARGS(IMIN); ARGS(IMIN) = TEMP1 
700:     END IF 
701: END DO 
702:  
703: END SUBROUTINE ARGSORT 
704:  
705: !function rargsort(a) result(b) 
706: !! Returns the indices that would sort an array. 
707: !! 
708: !! Arguments 
709: !! --------- 
710: !! 
711: !real(dp), intent(in):: a(:)   ! array of numbers 
712: !integer :: b(size(a))         ! indices into the array 'a' that sort it 
713: !! 
714: !! Example 
715: !! ------- 
716: !! 
717: !! rargsort([4.1_dp, 2.1_dp, 2.05_dp, -1.5_dp, 4.2_dp]) ! Returns [4, 3, 2, 1, 5] 
718: ! 
719: !integer :: N                           ! number of numbers/vectors 
720: !integer :: i,imin                      ! indices: i, i of smallest 
721: !integer :: temp1                       ! temporary 
722: !real(dp) :: temp2 
723: !real(dp) :: a2(size(a)) 
724: !a2 = a 
725: !N=size(a) 
726: !do i = 1, N 
727: !    b(i) = i 
728: !end do 
729: !do i = 1, N-1 
730: !    ! find ith smallest in 'a' 
731: !    imin = minloc(a2(i:),1) + i - 1 
732: !    ! swap to position i in 'a' and 'b', if not already there 
733: !    if (imin /= i) then 
734: !        temp2 = a2(i); a2(i) = a2(imin); a2(imin) = temp2 
735: !        temp1 = b(i); b(i) = b(imin); b(imin) = temp1 
736: !    end if 
737: !end do 
738: !end function 
739:  
740:  
741: END MODULE FASTOVERLAPUTILS 
742:  
743: !*********************************************************************** 
744:  
745: ! Some helper functions for calculating various orthogonal polynomials 
746:  
747: !*********************************************************************** 
748:  
749:  
750: DOUBLE PRECISION FUNCTION RLEGENDREL0(L, Z) 
751:  
752: ! Calcualates recurrence factor M1 for associated legendre polynomials@ 
753: ! P^{L+1}_{L+1} (Z) = L0*P^L_L (Z) 
754:  
755: IMPLICIT NONE 
756: INTEGER, INTENT(IN) :: L 
757: DOUBLE PRECISION, INTENT(IN) :: Z 
758:  
759: RLEGENDREL0 = - (2.D0*L+1) * (1-Z**2)**0.5  
760:  
761: END FUNCTION RLEGENDREL0 
762:  
763:  
764: DOUBLE PRECISION FUNCTION RLEGENDREM0(M, L, Z) 
765: ! Calcualates recurrence factor M1 for associated legendre polynomials@ 
766: ! P^{M-1}_L (Z) = M0*P^M_L (Z) + M1*P^{M+1}_L (Z) 
767:  
768: IMPLICIT NONE 
769: INTEGER, INTENT(IN) :: M, L 
770: DOUBLE PRECISION, INTENT(IN) :: Z 
771:  
772: RLEGENDREM0 = - 2.D0 * M * Z / (1.D0-Z**2)**0.5 / (L+M) / (L-M+1.D0) 
773:  
774: END FUNCTION RLEGENDREM0 
775:  
776: DOUBLE PRECISION FUNCTION RLEGENDREM1(M, L, Z) 
777: ! Calcualates recurrence factor M1 for associated legendre polynomials@ 
778: ! P^{M-1}_L (Z) = M0*P^M_L (Z) + M1*P^{M+1}_L (Z) 
779:  
780: IMPLICIT NONE 
781: INTEGER, INTENT(IN) :: M, L 
782: DOUBLE PRECISION, INTENT(IN) :: Z 
783:  
784: RLEGENDREM1 = - 1.D0 / (L+M) / (L-M+1.D0) 
785:  
786: END FUNCTION RLEGENDREM1 
787:  
788: function envj ( n, x ) 
789:  
790: !*****************************************************************************80 
791: ! 
792: !! ENVJ is a utility function used by MSTA1 and MSTA2. 
793: ! 
794: !  Discussion: 
795: ! 
796: !    ENVJ estimates -log(Jn(x)) from the estimate 
797: !    Jn(x) approx 1/sqrt(2*pi*n) * ( e*x/(2*n))^n 
798: ! 
799: !  Licensing: 
800: ! 
801: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,  
802: !    they give permission to incorporate this routine into a user program  
803: !    provided that the copyright is acknowledged. 
804: ! 
805: !  Modified: 
806: ! 
807: !    14 January 2016 
808: ! 
809: !  Author: 
810: ! 
811: !    Shanjie Zhang, Jianming Jin 
812: !    Modifications suggested by Vincent Lafage, 11 January 2016. 
813: ! 
814: !  Reference: 
815: ! 
816: !    Shanjie Zhang, Jianming Jin, 
817: !    Computation of Special Functions, 
818: !    Wiley, 1996, 
819: !    ISBN: 0-471-11963-6, 
820: !    LC: QA351.C45. 
821: ! 
822: !  Parameters: 
823: ! 
824: !    Input, integer ( kind = 4 ) N, the order of the Bessel function. 
825: ! 
826: !    Input, real ( kind = 8 ) X, the absolute value of the argument. 
827: ! 
828: !    Output, real ( kind = 8 ) ENVJ, the value. 
829: ! 
830:   implicit none 
831:  
832:   real ( kind = 8 ) envj 
833:   real ( kind = 8 ) logten 
834:   integer ( kind = 4 ) n 
835:   real ( kind = 8 ) n_r8 
836:   real ( kind = 8 ) r8_gamma_log 
837:   real ( kind = 8 ) x 
838: ! 
839: !  Original code 
840: ! 
841:   if ( .true. ) then 
842:  
843:     envj = 0.5D+00 * log10 ( 6.28D+00 * n ) & 
844:       - n * log10 ( 1.36D+00 * x / n ) 
845: ! 
846: !  Modification suggested by Vincent Lafage. 
847: ! 
848:   else 
849:  
850:     n_r8 = real ( n, kind = 8 ) 
851:     logten = log ( 10.0D+00 ) 
852:     envj = r8_gamma_log ( n_r8 + 1.0D+00 ) / logten - n_r8 * log10 ( x ) 
853:  
854:   end if 
855:  
856:   return 
857: end 
858:  
859:  
860:  
861: function msta1 ( x, mp ) 
862:  
863: !*****************************************************************************80 
864: ! 
865: !! MSTA1 determines a backward recurrence starting point for Jn(x). 
866: ! 
867: !  Discussion: 
868: ! 
869: !    This procedure determines the starting point for backward   
870: !    recurrence such that the magnitude of     
871: !    Jn(x) at that point is about 10^(-MP). 
872: ! 
873: !  Licensing: 
874: ! 
875: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,  
876: !    they give permission to incorporate this routine into a user program  
877: !    provided that the copyright is acknowledged. 
878: ! 
879: !  Modified: 
880: ! 
881: !    08 July 2012 
882: ! 
883: !  Author: 
884: ! 
885: !    Shanjie Zhang, Jianming Jin 
886: ! 
887: !  Reference: 
888: ! 
889: !    Shanjie Zhang, Jianming Jin, 
890: !    Computation of Special Functions, 
891: !    Wiley, 1996, 
892: !    ISBN: 0-471-11963-6, 
893: !    LC: QA351.C45. 
894: ! 
895: !  Parameters: 
896: ! 
897: !    Input, real ( kind = 8 ) X, the argument. 
898: ! 
899: !    Input, integer ( kind = 4 ) MP, the negative logarithm of the  
900: !    desired magnitude. 
901: ! 
902: !    Output, integer ( kind = 4 ) MSTA1, the starting point. 
903: ! 
904:   implicit none 
905:  
906:   real ( kind = 8 ) a0 
907:   real ( kind = 8 ) envj 
908:   real ( kind = 8 ) f 
909:   real ( kind = 8 ) f0 
910:   real ( kind = 8 ) f1 
911:   integer ( kind = 4 ) it 
912:   integer ( kind = 4 ) mp 
913:   integer ( kind = 4 ) msta1 
914:   integer ( kind = 4 ) n0 
915:   integer ( kind = 4 ) n1 
916:   integer ( kind = 4 ) nn 
917:   real ( kind = 8 ) x 
918:  
919:   a0 = abs ( x ) 
920:   n0 = int ( 1.1D+00 * a0 ) + 1 
921:   f0 = envj ( n0, a0 ) - mp 
922:   n1 = n0 + 5 
923:   f1 = envj ( n1, a0 ) - mp 
924:   do it = 1, 20        
925:     nn = n1 - ( n1 - n0 ) / ( 1.0D+00 - f0 / f1 )                   
926:     f = envj ( nn, a0 ) - mp 
927:     if ( abs ( nn - n1 ) < 1 ) then 
928:       exit 
929:     end if 
930:     n0 = n1 
931:     f0 = f1 
932:     n1 = nn 
933:     f1 = f 
934:   end do 
935:  
936:   msta1 = nn 
937:  
938:   return 
939: end function msta1 
940:  
941: function msta2 ( x, n, mp ) 
942:  
943: !*****************************************************************************80 
944: ! 
945: !! MSTA2 determines a backward recurrence starting point for Jn(x). 
946: ! 
947: !  Discussion: 
948: ! 
949: !    This procedure determines the starting point for a backward 
950: !    recurrence such that all Jn(x) has MP significant digits. 
951: ! 
952: !    Jianming Jin supplied a modification to this code on 12 January 2016. 
953: ! 
954: !  Licensing: 
955: ! 
956: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,  
957: !    they give permission to incorporate this routine into a user program  
958: !    provided that the copyright is acknowledged. 
959: ! 
960: !  Modified: 
961: ! 
962: !    14 January 2016 
963: ! 
964: !  Author: 
965: ! 
966: !    Shanjie Zhang, Jianming Jin 
967: ! 
968: !  Reference: 
969: ! 
970: !    Shanjie Zhang, Jianming Jin, 
971: !    Computation of Special Functions, 
972: !    Wiley, 1996, 
973: !    ISBN: 0-471-11963-6, 
974: !    LC: QA351.C45. 
975: ! 
976: !  Parameters: 
977: ! 
978: !    Input, real ( kind = 8 ) X, the argument of Jn(x). 
979: ! 
980: !    Input, integer ( kind = 4 ) N, the order of Jn(x). 
981: ! 
982: !    Input, integer ( kind = 4 ) MP, the number of significant digits. 
983: ! 
984: !    Output, integer ( kind = 4 ) MSTA2, the starting point. 
985: ! 
986:   implicit none 
987:  
988:   real ( kind = 8 ) a0 
989:   real ( kind = 8 ) ejn 
990:   real ( kind = 8 ) envj 
991:   real ( kind = 8 ) f 
992:   real ( kind = 8 ) f0 
993:   real ( kind = 8 ) f1 
994:   real ( kind = 8 ) hmp 
995:   integer ( kind = 4 ) it 
996:   integer ( kind = 4 ) mp 
997:   integer ( kind = 4 ) msta2 
998:   integer ( kind = 4 ) n 
999:   integer ( kind = 4 ) n0 
1000:   integer ( kind = 4 ) n1 
1001:   integer ( kind = 4 ) nn 
1002:   real ( kind = 8 ) obj 
1003:   real ( kind = 8 ) x 
1004:  
1005:   a0 = abs ( x ) 
1006:   hmp = 0.5D+00 * mp 
1007:   ejn = envj ( n, a0 ) 
1008:  
1009:   if ( ejn <= hmp ) then 
1010:     obj = mp 
1011: ! 
1012: !  Original code: 
1013: ! 
1014: !   n0 = int ( 1.1D+00 * a0 ) 
1015: ! 
1016: !  Updated code: 
1017: ! 
1018:     n0 = int ( 1.1D+00 * a0 ) + 1 
1019:   else 
1020:     obj = hmp + ejn 
1021:     n0 = n 
1022:   end if 
1023:  
1024:   f0 = envj ( n0, a0 ) - obj 
1025:   n1 = n0 + 5 
1026:   f1 = envj ( n1, a0 ) - obj 
1027:  
1028:   do it = 1, 20 
1029:     nn = n1 - ( n1 - n0 ) / ( 1.0D+00 - f0 / f1 ) 
1030:     f = envj ( nn, a0 ) - obj 
1031:     if ( abs ( nn - n1 ) < 1 ) then 
1032:       exit 
1033:     end if 
1034:     n0 = n1 
1035:     f0 = f1 
1036:     n1 = nn 
1037:     f1 = f 
1038:   end do 
1039:  
1040:   msta2 = nn + 10 
1041:  
1042:   return 
1043: end function msta2 
1044:  
1045: subroutine sphi ( n, x, nm, si) 
1046:  
1047: !*****************************************************************************80 
1048: ! 
1049: !! SPHI computes spherical Bessel functions in(x) and their derivatives in'(x). 
1050: ! 
1051: !  Licensing: 
1052: ! 
1053: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,  
1054: !    they give permission to incorporate this routine into a user program  
1055: !    provided that the copyright is acknowledged. 
1056: ! 
1057: !  Modified: 
1058: ! 
1059: !    18 July 2012 
1060: ! 
1061: !  Author: 
1062: ! 
1063: !    Shanjie Zhang, Jianming Jin 
1064: ! 
1065: !  Reference: 
1066: ! 
1067: !    Shanjie Zhang, Jianming Jin, 
1068: !    Computation of Special Functions, 
1069: !    Wiley, 1996, 
1070: !    ISBN: 0-471-11963-6, 
1071: !    LC: QA351.C45. 
1072: ! 
1073: !  Parameters: 
1074: ! 
1075: !    Input, integer ( kind = 4 ) N, the order of In(X). 
1076: ! 
1077: !    Input, real ( kind = 8 ) X, the argument. 
1078: ! 
1079: !    Output, integer ( kind = 4 ) NM, the highest order computed. 
1080: ! 
1081: !    Output, real ( kind = 8 ) SI(0:N), DI(0:N), the values and derivatives 
1082: !    of the function of orders 0 through N. 
1083: ! 
1084:   implicit none 
1085:  
1086:   integer ( kind = 4 ), intent(in) :: n 
1087:  
1088:   real ( kind = 8 ) cs 
1089:   real ( kind = 8 ) f 
1090:   real ( kind = 8 ) f0 
1091:   real ( kind = 8 ) f1 
1092:   integer ( kind = 4 ) k 
1093:   integer ( kind = 4 ) m 
1094:   integer ( kind = 4 ) msta1 
1095:   integer ( kind = 4 ) msta2 
1096:   integer ( kind = 4 ), intent(out) :: nm 
1097:   real ( kind = 8 ), intent(out) :: si(0:n) 
1098:   real ( kind = 8 ) si0 
1099:   real ( kind = 8 ), intent(in) :: x 
1100:  
1101:   nm = n 
1102:  
1103:   if ( abs ( x ) < 1.0D-100 ) then 
1104:     do k = 0, n 
1105:       si(k) = 0.0D+00 
1106:     end do 
1107:     si(0) = 1.0D+00 
1108:     return 
1109:   end if 
1110:  
1111:   si(0) = sinh ( x ) / x 
1112:   si(1) = -( sinh ( x ) / x - cosh ( x ) ) / x 
1113:   si0 = si(0) 
1114:  
1115:   if ( 2 <= n ) then 
1116:  
1117:     m = msta1 ( x, 200 ) 
1118:     if ( m < n ) then 
1119:       nm = m 
1120:     else 
1121:       m = msta2 ( x, n, 15 ) 
1122:     end if 
1123:     f0 = 0.0D+00 
1124:     f1 = 1.0D+00-100 
1125:     do k = m, 0, -1 
1126:       f = ( 2.0D+00 * k + 3.0D+00 ) * f1 / x + f0 
1127:       if ( k <= nm ) then 
1128:         si(k) = f 
1129:       end if 
1130:       f0 = f1 
1131:       f1 = f 
1132:     end do 
1133:     cs = si0 / f 
1134:     do k = 0, nm 
1135:       si(k) = cs * si(k) 
1136:     end do 
1137:  
1138:   end if 
1139:  
1140:   return 
1141: end subroutine sphi 
1142:  
1143:  
1144: subroutine HYP1F1 ( ain, bin, xin, hg ) 
1145:  
1146: !*****************************************************************************80 
1147: ! 
1148: !! CHGM computes the confluent hypergeometric function M(a,b,x). 
1149: ! 
1150: !  Licensing: 
1151: ! 
1152: !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,  
1153: !    they give permission to incorporate this routine into a user program  
1154: !    provided that the copyright is acknowledged. 
1155: ! 
1156: !  Modified: 
1157: ! 
1158: !    27 July 2012 
1159: ! 
1160: !  Author: 
1161: ! 
1162: !    Shanjie Zhang, Jianming Jin 
1163: ! 
1164: !  Reference: 
1165: ! 
1166: !    Shanjie Zhang, Jianming Jin, 
1167: !    Computation of Special Functions, 
1168: !    Wiley, 1996, 
1169: !    ISBN: 0-471-11963-6, 
1170: !    LC: QA351.C45. 
1171: ! 
1172: !  Parameters: 
1173: ! 
1174: !    Input, real ( kind = 8 ) A, B, parameters. 
1175: ! 
1176: !    Input, real ( kind = 8 ) X, the argument. 
1177: ! 
1178: !    Output, real ( kind = 8 ) HG, the value of M(a,b,x). 
1179: ! 
1180:   implicit none 
1181:  
1182:   real ( kind = 8 ), intent(in) :: ain 
1183:   real ( kind = 8 ), intent(in) :: bin 
1184:   real ( kind = 8 ), intent(in) :: xin 
1185:   real ( kind = 8 ), intent(out) :: hg 
1186:  
1187:   real ( kind = 8 ) a 
1188:   real ( kind = 8 ) b 
1189:   real ( kind = 8 ) x 
1190:  
1191:   real ( kind = 8 ) a0 
1192:   real ( kind = 8 ) a1 
1193:   real ( kind = 8 ) aa 
1194:  
1195:   real ( kind = 8 ) hg1 
1196:   real ( kind = 8 ) hg2 
1197:   integer ( kind = 4 ) i 
1198:   integer ( kind = 4 ) j 
1199:   integer ( kind = 4 ) k 
1200:   integer ( kind = 4 ) la 
1201:   integer ( kind = 4 ) m 
1202:   integer ( kind = 4 ) n 
1203:   integer ( kind = 4 ) nl 
1204:   real ( kind = 8 ) pi 
1205:   real ( kind = 8 ) r 
1206:   real ( kind = 8 ) r1 
1207:   real ( kind = 8 ) r2 
1208:   real ( kind = 8 ) rg 
1209:   real ( kind = 8 ) sum1 
1210:   real ( kind = 8 ) sum2 
1211:   real ( kind = 8 ) ta 
1212:   real ( kind = 8 ) tb 
1213:   real ( kind = 8 ) tba 
1214:   real ( kind = 8 ) x0 
1215:   real ( kind = 8 ) xg 
1216:   real ( kind = 8 ) y0 
1217:   real ( kind = 8 ) y1 
1218:  
1219:   a=ain 
1220:   b=bin 
1221:   x=xin 
1222:   pi = 3.141592653589793D+00 
1223:   a0 = a 
1224:   a1 = a 
1225:   x0 = x 
1226:   hg = 0.0D+00 
1227:  
1228:   y1 = hg 
1229:  
1230:   if ( b == 0.0D+00 .or. b == - abs ( int ( b ) ) ) then 
1231:     hg = 1.0D+300 
1232:   else if ( a == 0.0D+00 .or. x == 0.0D+00 ) then 
1233:     hg = 1.0D+00 
1234:   else if ( a == -1.0D+00 ) then 
1235:     hg = 1.0D+00 - x / b 
1236:   else if ( a == b ) then 
1237:     hg = exp ( x ) 
1238:   else if ( a - b == 1.0D+00 ) then 
1239:     hg = ( 1.0D+00 + x / b ) * exp ( x ) 
1240:   else if ( a == 1.0D+00 .and. b == 2.0D+00 ) then 
1241:     hg = ( exp ( x ) - 1.0D+00 ) / x 
1242:   else if ( a == int ( a ) .and. a < 0.0D+00 ) then 
1243:     m = int ( - a ) 
1244:     r = 1.0D+00 
1245:     hg = 1.0D+00 
1246:     do k = 1, m 
1247:       r = r * ( a + k - 1.0D+00 ) / k / ( b + k - 1.0D+00 ) * x 
1248:       hg = hg + r 
1249:     end do 
1250:   end if 
1251:  
1252:   if ( hg /= 0.0D+00 ) then 
1253:     return 
1254:   end if 
1255:  
1256:   if ( x < 0.0D+00 ) then 
1257:     a = b - a 
1258:     a0 = a 
1259:     x = abs ( x ) 
1260:   end if 
1261:  
1262:   if ( a < 2.0D+00 ) then 
1263:     nl = 0 
1264:   end if 
1265:  
1266:   if ( 2.0D+00 <= a ) then 
1267:     nl = 1 
1268:     la = int ( a ) 
1269:     a = a - la - 1.0D+00 
1270:   end if 
1271:  
1272:   do n = 0, nl 
1273:  
1274:     if ( 2.0D+00 <= a0 ) then 
1275:       a = a + 1.0D+00 
1276:     end if 
1277:  
1278:     if ( x <= 30.0D+00 + abs ( b ) .or. a < 0.0D+00 ) then 
1279:  
1280:       hg = 1.0D+00 
1281:       rg = 1.0D+00 
1282:       do j = 1, 500 
1283:         rg = rg * ( a + j - 1.0D+00 ) & 
1284:           / ( j * ( b + j - 1.0D+00 ) ) * x 
1285:         hg = hg + rg 
1286:         if ( abs ( rg / hg ) < 1.0D-15 ) then 
1287:           exit 
1288:         end if 
1289:       end do 
1290:  
1291:     else 
1292:  
1293:       call gamma ( a, ta ) 
1294:       call gamma ( b, tb ) 
1295:       xg = b - a 
1296:       call gamma ( xg, tba ) 
1297:       sum1 = 1.0D+00 
1298:       sum2 = 1.0D+00 
1299:       r1 = 1.0D+00 
1300:       r2 = 1.0D+00 
1301:       do i = 1, 8 
1302:         r1 = - r1 * ( a + i - 1.0D+00 ) * ( a - b + i ) / ( x * i ) 
1303:         r2 = - r2 * ( b - a + i - 1.0D+00 ) * ( a - i ) / ( x * i ) 
1304:         sum1 = sum1 + r1 
1305:         sum2 = sum2 + r2 
1306:       end do 
1307:       hg1 = tb / tba * x ** ( - a ) * cos ( pi * a ) * sum1 
1308:       hg2 = tb / ta * exp ( x ) * x ** ( a - b ) * sum2 
1309:       hg = hg1 + hg2 
1310:  
1311:     end if 
1312:  
1313:     if ( n == 0 ) then 
1314:       y0 = hg 
1315:     else if ( n == 1 ) then 
1316:       y1 = hg 
1317:     end if 
1318:  
1319:   end do 
1320:  
1321:   if ( 2.0D+00 <= a0 ) then 
1322:     do i = 1, la - 1 
1323:       hg = ( ( 2.0D+00 * a - b + x ) * y1 + ( b - a ) * y0 ) / a 
1324:       y0 = y1 
1325:       y1 = hg 
1326:       a = a + 1.0D+00 
1327:     end do 
1328:   end if 
1329:  
1330:   if ( x0 < 0.0D+00 ) then 
1331:     hg = hg * exp ( x0 ) 
1332:   end if 
1333:  
1334:   a = a1 
1335:   x = x0 
1336:  
1337:   return 
1338: end 
1339:  
1340: subroutine gamma ( x, ga ) 
1341:  
1342: !*****************************************************************************80 
1343: ! 
1344: !! GAMMA evaluates the Gamma function. 
1345: ! 
1346: !  Licensing: 
1347: ! 
1348: !    The original FORTRAN77 version of this routine is copyrighted by  
1349: !    Shanjie Zhang and Jianming Jin.  However, they give permission to  
1350: !    incorporate this routine into a user program that the copyright  
1351: !    is acknowledged. 
1352: ! 
1353: !  Modified: 
1354: ! 
1355: !    08 September 2007 
1356: ! 
1357: !  Author: 
1358: ! 
1359: !    Original FORTRAN77 version by Shanjie Zhang, Jianming Jin. 
1360: !    FORTRAN90 version by John Burkardt. 
1361: ! 
1362: !  Reference: 
1363: ! 
1364: !    Shanjie Zhang, Jianming Jin, 
1365: !    Computation of Special Functions, 
1366: !    Wiley, 1996, 
1367: !    ISBN: 0-471-11963-6, 
1368: !    LC: QA351.C45 
1369: ! 
1370: !  Parameters: 
1371: ! 
1372: !    Input, real ( kind = 8 ) X, the argument. 
1373: !    X must not be 0, or any negative integer. 
1374: ! 
1375: !    Output, real ( kind = 8 ) GA, the value of the Gamma function. 
1376: ! 
1377:   implicit none 
1378:  
1379:   real ( kind = 8 ), intent(in) :: x 
1380:   real ( kind = 8 ), intent(out) :: ga 
1381:  
1382:   real ( kind = 8 ), dimension ( 26 ) :: g = (/ & 
1383:     1.0D+00, & 
1384:     0.5772156649015329D+00, & 
1385:    -0.6558780715202538D+00, & 
1386:    -0.420026350340952D-01, & 
1387:     0.1665386113822915D+00, & 
1388:    -0.421977345555443D-01, & 
1389:    -0.96219715278770D-02, & 
1390:     0.72189432466630D-02, & 
1391:    -0.11651675918591D-02, & 
1392:    -0.2152416741149D-03, & 
1393:     0.1280502823882D-03, &  
1394:    -0.201348547807D-04, & 
1395:    -0.12504934821D-05, & 
1396:     0.11330272320D-05, & 
1397:    -0.2056338417D-06, &  
1398:     0.61160950D-08, & 
1399:     0.50020075D-08, & 
1400:    -0.11812746D-08, & 
1401:     0.1043427D-09, &  
1402:     0.77823D-11, & 
1403:    -0.36968D-11, & 
1404:     0.51D-12, & 
1405:    -0.206D-13, & 
1406:    -0.54D-14, & 
1407:     0.14D-14, & 
1408:     0.1D-15 /) 
1409:  
1410:   real ( kind = 8 ) gr 
1411:   integer ( kind = 4 ) k 
1412:   integer ( kind = 4 ) m 
1413:   integer ( kind = 4 ) m1 
1414:   real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 
1415:   real ( kind = 8 ) r 
1416:   real ( kind = 8 ) z 
1417:  
1418:   if ( x == aint ( x ) ) then 
1419:  
1420:     if ( 0.0D+00 < x ) then 
1421:       ga = 1.0D+00 
1422:       m1 = int ( x ) - 1 
1423:       do k = 2, m1 
1424:         ga = ga * k 
1425:       end do 
1426:     else 
1427:       ga = 1.0D+300 
1428:     end if 
1429:  
1430:   else 
1431:  
1432:     if ( 1.0D+00 < abs ( x ) ) then 
1433:       z = abs ( x ) 
1434:       m = int ( z ) 
1435:       r = 1.0D+00 
1436:       do k = 1, m 
1437:         r = r * ( z - real ( k, kind = 8 ) ) 
1438:       end do 
1439:       z = z - real ( m, kind = 8 ) 
1440:     else 
1441:       z = x 
1442:     end if 
1443:  
1444:     gr = g(26) 
1445:     do k = 25, 1, -1 
1446:       gr = gr * z + g(k) 
1447:     end do 
1448:  
1449:     ga = 1.0D+00 / ( gr * z ) 
1450:  
1451:     if ( 1.0D+00 < abs ( x ) ) then 
1452:       ga = ga * r 
1453:       if ( x < 0.0D+00 ) then 
1454:         ga = - pi / ( x* ga * sin ( pi * x ) ) 
1455:       end if 
1456:     end if 
1457:  
1458:   end if 
1459:  
1460:   return 
1461: end 
1462:  
1463:  
1464:  
1465: !    CODE REPRODUCED FROM MINPACK UNDER THE GNU LPGL LICENCE: 
1466:  
1467: !    REFERENCES: 
1468:  
1469: !    Jorge More, Burton Garbow, Kenneth Hillstrom, 
1470: !    User Guide for MINPACK-1, 
1471: !    Technical Report ANL-80-74, 
1472: !    Argonne National Laboratory, 1980. 
1473:      
1474: !    Jorge More, Danny Sorenson, Burton Garbow, Kenneth Hillstrom, 
1475: !    The MINPACK Project, 
1476: !    in Sources and Development of Mathematical Software, 
1477: !    edited by Wayne Cowell, 
1478: !    Prentice-Hall, 1984, 
1479: !    ISBN: 0-13-823501-5, 
1480: !    LC: QA76.95.S68. 
1481:  
1482:  
1483:  
1484: subroutine lmder ( fcn, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, maxfev, & 
1485:   diag, mode, factor, nprint, info, nfev, njev, ipvt, qtf ) 
1486:  
1487: !*****************************************************************************80 
1488: ! 
1489: !! LMDER minimizes M functions in N variables by the Levenberg-Marquardt method. 
1490: ! 
1491: !  Discussion: 
1492: ! 
1493: !    LMDER minimizes the sum of the squares of M nonlinear functions in 
1494: !    N variables by a modification of the Levenberg-Marquardt algorithm. 
1495: !    The user must provide a subroutine which calculates the functions 
1496: !    and the jacobian. 
1497: ! 
1498: !  Licensing: 
1499: ! 
1500: !    This code is distributed under the GNU LGPL license. 
1501: ! 
1502: !  Modified: 
1503: ! 
1504: !    06 April 2010 
1505: ! 
1506: !  Author: 
1507: ! 
1508: !    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom. 
1509: !    FORTRAN90 version by John Burkardt. 
1510: ! 
1511: !  Reference: 
1512: ! 
1513: !    Jorge More, Burton Garbow, Kenneth Hillstrom, 
1514: !    User Guide for MINPACK-1, 
1515: !    Technical Report ANL-80-74, 
1516: !    Argonne National Laboratory, 1980. 
1517: ! 
1518: !  Parameters: 
1519: ! 
1520: !    Input, external FCN, the name of the user-supplied subroutine which 
1521: !    calculates the functions and the jacobian.  FCN should have the form: 
1522: !      subroutine fcn ( m, n, x, fvec, fjac, ldfjac, iflag ) 
1523: !      integer ( kind = 4 ) ldfjac 
1524: !      integer ( kind = 4 ) n 
1525: !      real ( kind = 8 ) fjac(ldfjac,n) 
1526: !      real ( kind = 8 ) fvec(m) 
1527: !      integer ( kind = 4 ) iflag 
1528: !      real ( kind = 8 ) x(n) 
1529: ! 
1530: !    If IFLAG = 0 on input, then FCN is only being called to allow the user 
1531: !    to print out the current iterate. 
1532: !    If IFLAG = 1 on input, FCN should calculate the functions at X and 
1533: !    return this vector in FVEC. 
1534: !    If IFLAG = 2 on input, FCN should calculate the jacobian at X and 
1535: !    return this matrix in FJAC. 
1536: !    To terminate the algorithm, FCN may set IFLAG negative on return. 
1537: ! 
1538: !    Input, integer ( kind = 4 ) M, is the number of functions. 
1539: ! 
1540: !    Input, integer ( kind = 4 ) N, is the number of variables.   
1541: !    N must not exceed M. 
1542: ! 
1543: !    Input/output, real ( kind = 8 ) X(N).  On input, X must contain an initial 
1544: !    estimate of the solution vector.  On output X contains the final 
1545: !    estimate of the solution vector. 
1546: ! 
1547: !    Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X. 
1548: ! 
1549: !    Output, real ( kind = 8 ) FJAC(LDFJAC,N), an M by N array.  The upper 
1550: !    N by N submatrix of FJAC contains an upper triangular matrix R with 
1551: !    diagonal elements of nonincreasing magnitude such that 
1552: !      P' * ( JAC' * JAC ) * P = R' * R, 
1553: !    where P is a permutation matrix and JAC is the final calculated jacobian. 
1554: !    Column J of P is column IPVT(J) of the identity matrix.  The lower 
1555: !    trapezoidal part of FJAC contains information generated during 
1556: !    the computation of R. 
1557: ! 
1558: !    Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC. 
1559: !    LDFJAC must be at least M. 
1560: ! 
1561: !    Input, real ( kind = 8 ) FTOL.  Termination occurs when both the actual 
1562: !    and predicted relative reductions in the sum of squares are at most FTOL. 
1563: !    Therefore, FTOL measures the relative error desired in the sum of 
1564: !    squares.  FTOL should be nonnegative. 
1565: ! 
1566: !    Input, real ( kind = 8 ) XTOL.  Termination occurs when the relative error 
1567: !    between two consecutive iterates is at most XTOL.  XTOL should be 
1568: !    nonnegative. 
1569: ! 
1570: !    Input, real ( kind = 8 ) GTOL.  Termination occurs when the cosine of the 
1571: !    angle between FVEC and any column of the jacobian is at most GTOL in 
1572: !    absolute value.  Therefore, GTOL measures the orthogonality desired 
1573: !    between the function vector and the columns of the jacobian.  GTOL should 
1574: !    be nonnegative. 
1575: ! 
1576: !    Input, integer ( kind = 4 ) MAXFEV.  Termination occurs when the number of 
1577: !    calls to FCN with IFLAG = 1 is at least MAXFEV by the end of an iteration. 
1578: ! 
1579: !    Input/output, real ( kind = 8 ) DIAG(N).  If MODE = 1, then DIAG is set 
1580: !    internally.  If MODE = 2, then DIAG must contain positive entries that 
1581: !    serve as multiplicative scale factors for the variables. 
1582: ! 
1583: !    Input, integer ( kind = 4 ) MODE, scaling option. 
1584: !    1, variables will be scaled internally. 
1585: !    2, scaling is specified by the input DIAG vector. 
1586: ! 
1587: !    Input, real ( kind = 8 ) FACTOR, determines the initial step bound.  This 
1588: !    bound is set to the product of FACTOR and the euclidean norm of DIAG*X if 
1589: !    nonzero, or else to FACTOR itself.  In most cases, FACTOR should lie 
1590: !    in the interval (0.1, 100) with 100 the recommended value. 
1591: ! 
1592: !    Input, integer ( kind = 4 ) NPRINT, enables controlled printing of iterates 
1593: !    if it is positive.  In this case, FCN is called with IFLAG = 0 at the 
1594: !    beginning of the first iteration and every NPRINT iterations thereafter 
1595: !    and immediately prior to return, with X and FVEC available 
1596: !    for printing.  If NPRINT is not positive, no special calls 
1597: !    of FCN with IFLAG = 0 are made. 
1598: ! 
1599: !    Output, integer ( kind = 4 ) INFO, error flag.  If the user has terminated 
1600: !    execution, INFO is set to the (negative) value of IFLAG. See description 
1601: !    of FCN.  Otherwise, INFO is set as follows: 
1602: !    0, improper input parameters. 
1603: !    1, both actual and predicted relative reductions in the sum of 
1604: !       squares are at most FTOL. 
1605: !    2, relative error between two consecutive iterates is at most XTOL. 
1606: !    3, conditions for INFO = 1 and INFO = 2 both hold. 
1607: !    4, the cosine of the angle between FVEC and any column of the jacobian 
1608: !       is at most GTOL in absolute value. 
1609: !    5, number of calls to FCN with IFLAG = 1 has reached MAXFEV. 
1610: !    6, FTOL is too small.  No further reduction in the sum of squares 
1611: !       is possible. 
1612: !    7, XTOL is too small.  No further improvement in the approximate 
1613: !       solution X is possible. 
1614: !    8, GTOL is too small.  FVEC is orthogonal to the columns of the 
1615: !       jacobian to machine precision. 
1616: ! 
1617: !    Output, integer ( kind = 4 ) NFEV, the number of calls to FCN with 
1618: !    IFLAG = 1. 
1619: ! 
1620: !    Output, integer ( kind = 4 ) NJEV, the number of calls to FCN with 
1621: !    IFLAG = 2. 
1622: ! 
1623: !    Output, integer ( kind = 4 ) IPVT(N), defines a permutation matrix P 
1624: !    such that JAC*P = Q*R, where JAC is the final calculated jacobian, Q is 
1625: !    orthogonal (not stored), and R is upper triangular with diagonal 
1626: !    elements of nonincreasing magnitude.  Column J of P is column 
1627: !    IPVT(J) of the identity matrix. 
1628: ! 
1629: !    Output, real ( kind = 8 ) QTF(N), contains the first N elements of Q'*FVEC. 
1630: ! 
1631:   implicit none 
1632:  
1633:   integer ( kind = 4 ), INTENT(IN) :: ldfjac 
1634:   integer ( kind = 4 ), INTENT(IN) ::  m 
1635:   integer ( kind = 4 ), INTENT(IN) ::  n 
1636:  
1637:   real ( kind = 8 ) actred 
1638:   real ( kind = 8 ) delta 
1639:   real ( kind = 8 ), INTENT(INOUT) :: diag(n) 
1640:   real ( kind = 8 ) dirder 
1641:   real ( kind = 8 ) enorm 
1642:   real ( kind = 8 ) epsmch 
1643:   real ( kind = 8 ), INTENT(IN) :: factor 
1644:   external  fcn 
1645:   real ( kind = 8 ), INTENT(OUT) :: fjac(ldfjac,n) 
1646:   real ( kind = 8 ) fnorm 
1647:   real ( kind = 8 ) fnorm1 
1648:   real ( kind = 8 ), INTENT(IN) :: ftol 
1649:   real ( kind = 8 ), INTENT(OUT) :: fvec(m) 
1650:   real ( kind = 8 ) gnorm 
1651:   real ( kind = 8 ), INTENT(IN) :: gtol 
1652:   integer ( kind = 4 ) i 
1653:   integer ( kind = 4 ) iflag 
1654:   integer ( kind = 4 ), INTENT(OUT) :: info 
1655:   integer ( kind = 4 ) ipvt(n) 
1656:   integer ( kind = 4 ) iter 
1657:   integer ( kind = 4 ) j 
1658:   integer ( kind = 4 ) l 
1659:   integer ( kind = 4 ), INTENT(IN) :: maxfev 
1660:   integer ( kind = 4 ), INTENT(IN) :: mode 
1661:   integer ( kind = 4 ), INTENT(OUT) :: nfev 
1662:   integer ( kind = 4 ), INTENT(OUT) :: njev 
1663:   integer ( kind = 4 ), INTENT(IN) :: nprint 
1664:   real ( kind = 8 ) par 
1665:   logical pivot 
1666:   real ( kind = 8 ) pnorm 
1667:   real ( kind = 8 ) prered 
1668:   real ( kind = 8 ), INTENT(OUT) :: qtf(n) 
1669:   real ( kind = 8 ) ratio 
1670:   real ( kind = 8 ) sum2 
1671:   real ( kind = 8 ) temp 
1672:   real ( kind = 8 ) temp1 
1673:   real ( kind = 8 ) temp2 
1674:   real ( kind = 8 ) wa1(n) 
1675:   real ( kind = 8 ) wa2(n) 
1676:   real ( kind = 8 ) wa3(n) 
1677:   real ( kind = 8 ) wa4(m) 
1678:   real ( kind = 8 ) xnorm 
1679:   real ( kind = 8 ), INTENT(INOUT) ::  x(n) 
1680:   real ( kind = 8 ), INTENT(IN) :: xtol 
1681:  
1682:   epsmch = epsilon ( epsmch ) 
1683:  
1684:   info = 0 
1685:   iflag = 0 
1686:   nfev = 0 
1687:   njev = 0 
1688: ! 
1689: !  Check the input parameters for errors. 
1690: ! 
1691:   if ( n <= 0 ) then 
1692:     go to 300 
1693:   end if 
1694:  
1695:   if ( m < n ) then 
1696:     go to 300 
1697:   end if 
1698:  
1699:   if ( ldfjac < m & 
1700:     .or. ftol < 0.0D+00 .or. xtol < 0.0D+00 .or. gtol < 0.0D+00 & 
1701:      .or. maxfev <= 0 .or. factor <= 0.0D+00 ) then 
1702:     go to 300 
1703:   end if 
1704:  
1705:   if ( mode == 2 ) then 
1706:     do j = 1, n 
1707:       if ( diag(j) <= 0.0D+00 ) then 
1708:         go to 300 
1709:       end if 
1710:     end do 
1711:   end if 
1712: ! 
1713: !  Evaluate the function at the starting point and calculate its norm. 
1714: ! 
1715:   iflag = 1 
1716:   call fcn ( m, n, x, fvec, fjac, ldfjac, iflag ) 
1717:   nfev = 1 
1718:   if ( iflag < 0 ) then 
1719:     go to 300 
1720:   end if 
1721:  
1722:   fnorm = enorm ( m, fvec ) 
1723: ! 
1724: !  Initialize Levenberg-Marquardt parameter and iteration counter. 
1725: ! 
1726:   par = 0.0D+00 
1727:   iter = 1 
1728: ! 
1729: !  Beginning of the outer loop. 
1730: ! 
1731: 30   continue 
1732: ! 
1733: !  Calculate the jacobian matrix. 
1734: ! 
1735:     iflag = 2 
1736:     call fcn ( m, n, x, fvec, fjac, ldfjac, iflag ) 
1737:  
1738:     njev = njev + 1 
1739:  
1740:     if ( iflag < 0 ) then 
1741:       go to 300 
1742:     end if 
1743: ! 
1744: !  If requested, call FCN to enable printing of iterates. 
1745: ! 
1746:     if ( 0 < nprint ) then 
1747:       iflag = 0 
1748:       if ( mod ( iter - 1, nprint ) == 0 ) then 
1749:         call fcn ( m, n, x, fvec, fjac, ldfjac, iflag ) 
1750:       end if 
1751:       if ( iflag < 0 ) then 
1752:         go to 300 
1753:       end if 
1754:     end if 
1755: ! 
1756: !  Compute the QR factorization of the jacobian. 
1757: ! 
1758:     pivot = .true. 
1759:     call qrfac ( m, n, fjac, ldfjac, pivot, ipvt, n, wa1, wa2 ) 
1760: ! 
1761: !  On the first iteration and if mode is 1, scale according 
1762: !  to the norms of the columns of the initial jacobian. 
1763: ! 
1764:     if ( iter == 1 ) then 
1765:  
1766:       if ( mode /= 2 ) then 
1767:         diag(1:n) = wa2(1:n) 
1768:         do j = 1, n 
1769:           if ( wa2(j) == 0.0D+00 ) then 
1770:             diag(j) = 1.0D+00 
1771:           end if 
1772:         end do 
1773:       end if 
1774: ! 
1775: !  On the first iteration, calculate the norm of the scaled X 
1776: !  and initialize the step bound DELTA. 
1777: ! 
1778:       wa3(1:n) = diag(1:n) * x(1:n) 
1779:  
1780:       xnorm = enorm ( n, wa3 ) 
1781:       delta = factor * xnorm 
1782:       if ( delta == 0.0D+00 ) then 
1783:         delta = factor 
1784:       end if 
1785:  
1786:     end if 
1787: ! 
1788: !  Form Q'*FVEC and store the first N components in QTF. 
1789: ! 
1790:     wa4(1:m) = fvec(1:m) 
1791:  
1792:     do j = 1, n 
1793:  
1794:       if ( fjac(j,j) /= 0.0D+00 ) then 
1795:         sum2 = dot_product ( wa4(j:m), fjac(j:m,j) ) 
1796:         temp = - sum2 / fjac(j,j) 
1797:         wa4(j:m) = wa4(j:m) + fjac(j:m,j) * temp 
1798:       end if 
1799:  
1800:       fjac(j,j) = wa1(j) 
1801:       qtf(j) = wa4(j) 
1802:  
1803:     end do 
1804: ! 
1805: !  Compute the norm of the scaled gradient. 
1806: ! 
1807:     gnorm = 0.0D+00 
1808:  
1809:     if ( fnorm /= 0.0D+00 ) then 
1810:  
1811:       do j = 1, n 
1812:         l = ipvt(j) 
1813:         if ( wa2(l) /= 0.0D+00 ) then 
1814:           sum2 = dot_product ( qtf(1:j), fjac(1:j,j) ) / fnorm 
1815:           gnorm = max ( gnorm, abs ( sum2 / wa2(l) ) ) 
1816:         end if 
1817:       end do 
1818:  
1819:     end if 
1820: ! 
1821: !  Test for convergence of the gradient norm. 
1822: ! 
1823:     if ( gnorm <= gtol ) then 
1824:       info = 4 
1825:       go to 300 
1826:     end if 
1827: ! 
1828: !  Rescale if necessary. 
1829: ! 
1830:     if ( mode /= 2 ) then 
1831:       do j = 1, n 
1832:         diag(j) = max ( diag(j), wa2(j) ) 
1833:       end do 
1834:     end if 
1835: ! 
1836: !  Beginning of the inner loop. 
1837: ! 
1838: 200    continue 
1839: ! 
1840: !  Determine the Levenberg-Marquardt parameter. 
1841: ! 
1842:     call lmpar ( n, fjac, ldfjac, ipvt, diag, qtf, delta, par, wa1, wa2 ) 
1843: ! 
1844: !  Store the direction p and x + p. calculate the norm of p. 
1845: ! 
1846:     wa1(1:n) = - wa1(1:n) 
1847:     wa2(1:n) = x(1:n) + wa1(1:n) 
1848:     wa3(1:n) = diag(1:n) * wa1(1:n) 
1849:  
1850:     pnorm = enorm ( n, wa3 ) 
1851: ! 
1852: !  On the first iteration, adjust the initial step bound. 
1853: ! 
1854:     if ( iter == 1 ) then 
1855:       delta = min ( delta, pnorm ) 
1856:     end if 
1857: ! 
1858: !  Evaluate the function at x + p and calculate its norm. 
1859: ! 
1860:     iflag = 1 
1861:     call fcn ( m, n, wa2, wa4, fjac, ldfjac, iflag ) 
1862:  
1863:     nfev = nfev + 1 
1864:  
1865:     if ( iflag < 0 ) then 
1866:       go to 300 
1867:     end if 
1868:  
1869:     fnorm1 = enorm ( m, wa4 ) 
1870: ! 
1871: !  Compute the scaled actual reduction. 
1872: ! 
1873:     actred = -1.0D+00 
1874:     if ( 0.1D+00 * fnorm1 < fnorm ) then 
1875:       actred = 1.0D+00 - ( fnorm1 / fnorm ) ** 2 
1876:     end if 
1877: ! 
1878: !  Compute the scaled predicted reduction and 
1879: !  the scaled directional derivative. 
1880: ! 
1881:     do j = 1, n 
1882:       wa3(j) = 0.0D+00 
1883:       l = ipvt(j) 
1884:       temp = wa1(l) 
1885:       wa3(1:j) = wa3(1:j) + fjac(1:j,j) * temp 
1886:     end do 
1887:  
1888:     temp1 = enorm ( n, wa3 ) / fnorm 
1889:     temp2 = ( sqrt ( par ) * pnorm ) / fnorm 
1890:     prered = temp1 ** 2 + temp2 ** 2 / 0.5D+00 
1891:     dirder = - ( temp1 ** 2 + temp2 ** 2 ) 
1892: ! 
1893: !  Compute the ratio of the actual to the predicted reduction. 
1894: ! 
1895:     if ( prered /= 0.0D+00 ) then 
1896:       ratio = actred / prered 
1897:     else 
1898:       ratio = 0.0D+00 
1899:     end if 
1900: ! 
1901: !  Update the step bound. 
1902: ! 
1903:     if ( ratio <= 0.25D+00 ) then 
1904:  
1905:       if ( 0.0D+00 <= actred ) then 
1906:         temp = 0.5D+00 
1907:       end if 
1908:  
1909:       if ( actred < 0.0D+00 ) then 
1910:         temp = 0.5D+00 * dirder / ( dirder + 0.5D+00 * actred ) 
1911:       end if 
1912:  
1913:       if ( 0.1D+00 * fnorm1 >= fnorm .or. temp < 0.1D+00 ) then 
1914:         temp = 0.1D+00 
1915:       end if 
1916:  
1917:       delta = temp * min ( delta, pnorm / 0.1D+00 ) 
1918:       par = par / temp 
1919:  
1920:     else 
1921:  
1922:       if ( par == 0.0D+00 .or. ratio >= 0.75D+00 ) then 
1923:         delta = 2.0D+00 * pnorm 
1924:         par = 0.5D+00 * par 
1925:       end if 
1926:  
1927:     end if 
1928: ! 
1929: !  Successful iteration. 
1930: ! 
1931: !  Update X, FVEC, and their norms. 
1932: ! 
1933:     if ( 0.0001D+00 <= ratio ) then 
1934:       x(1:n) = wa2(1:n) 
1935:       wa2(1:n) = diag(1:n) * x(1:n) 
1936:       fvec(1:m) = wa4(1:m) 
1937:       xnorm = enorm ( n, wa2 ) 
1938:       fnorm = fnorm1 
1939:       iter = iter + 1 
1940:     end if 
1941: ! 
1942: !  Tests for convergence. 
1943: ! 
1944:     if ( abs ( actred) <= ftol .and. & 
1945:       prered <= ftol .and. & 
1946:       0.5D+00 * ratio <= 1.0D+00 ) then 
1947:       info = 1 
1948:     end if 
1949:  
1950:     if ( delta <= xtol * xnorm ) then 
1951:       info = 2 
1952:     end if 
1953:  
1954:     if ( abs ( actred) <= ftol .and. prered <= ftol & 
1955:       .and. 0.5D+00 * ratio <= 1.0D+00 .and. info == 2 ) then 
1956:       info = 3 
1957:     end if 
1958:  
1959:     if ( info /= 0 ) then 
1960:       go to 300 
1961:     end if 
1962: ! 
1963: !  Tests for termination and stringent tolerances. 
1964: ! 
1965:     if ( nfev >= maxfev ) then 
1966:       info = 5 
1967:     end if 
1968:  
1969:     if ( abs ( actred ) <= epsmch .and. prered <= epsmch & 
1970:       .and. 0.5D+00 * ratio <= 1.0D+00 ) then 
1971:       info = 6 
1972:     end if 
1973:  
1974:     if ( delta <= epsmch * xnorm ) then 
1975:       info = 7 
1976:     end if 
1977:  
1978:     if ( gnorm <= epsmch ) then 
1979:       info = 8 
1980:     end if 
1981:  
1982:     if ( info /= 0 ) then 
1983:       go to 300 
1984:     end if 
1985: ! 
1986: !  End of the inner loop. repeat if iteration unsuccessful. 
1987: ! 
1988:     if ( ratio < 0.0001D+00 ) then 
1989:       go to 200 
1990:     end if 
1991: ! 
1992: !  End of the outer loop. 
1993: ! 
1994:     go to 30 
1995:  
1996:   300 continue 
1997: ! 
1998: !  Termination, either normal or user imposed. 
1999: ! 
2000:   if ( iflag < 0 ) then 
2001:     info = iflag 
2002:   end if 
2003:  
2004:   iflag = 0 
2005:  
2006:   if ( 0 < nprint ) then 
2007:     call fcn ( m, n, x, fvec, fjac, ldfjac, iflag ) 
2008:   end if 
2009:  
2010:   return 
2011: end 
2012:  
2013: subroutine lmder1 ( fcn, m, n, x, fvec, fjac, ldfjac, tol, info ) 
2014:  
2015: !*****************************************************************************80 
2016: ! 
2017: !! LMDER1 minimizes M functions in N variables by Levenberg-Marquardt method. 
2018: ! 
2019: !  Discussion: 
2020: ! 
2021: !    LMDER1 minimizes the sum of the squares of M nonlinear functions in 
2022: !    N variables by a modification of the Levenberg-Marquardt algorithm. 
2023: !    This is done by using the more general least-squares solver LMDER. 
2024: !    The user must provide a subroutine which calculates the functions 
2025: !    and the jacobian. 
2026: ! 
2027: !  Licensing: 
2028: ! 
2029: !    This code is distributed under the GNU LGPL license. 
2030: ! 
2031: !  Modified: 
2032: ! 
2033: !    06 April 2010 
2034: ! 
2035: !  Author: 
2036: ! 
2037: !    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom. 
2038: !    FORTRAN90 version by John Burkardt. 
2039: ! 
2040: !  Reference: 
2041: ! 
2042: !    Jorge More, Burton Garbow, Kenneth Hillstrom, 
2043: !    User Guide for MINPACK-1, 
2044: !    Technical Report ANL-80-74, 
2045: !    Argonne National Laboratory, 1980. 
2046: ! 
2047: !  Parameters: 
2048: ! 
2049: !    Input, external FCN, the name of the user-supplied subroutine which 
2050: !    calculates the functions and the jacobian.  FCN should have the form: 
2051: !      subroutine fcn ( m, n, x, fvec, fjac, ldfjac, iflag ) 
2052: !      integer ( kind = 4 ) ldfjac 
2053: !      integer ( kind = 4 ) n 
2054: !      real ( kind = 8 ) fjac(ldfjac,n) 
2055: !      real ( kind = 8 ) fvec(m) 
2056: !      integer ( kind = 4 ) iflag 
2057: !      real ( kind = 8 ) x(n) 
2058: ! 
2059: !    If IFLAG = 0 on input, then FCN is only being called to allow the user 
2060: !    to print out the current iterate. 
2061: !    If IFLAG = 1 on input, FCN should calculate the functions at X and 
2062: !    return this vector in FVEC. 
2063: !    If IFLAG = 2 on input, FCN should calculate the jacobian at X and 
2064: !    return this matrix in FJAC. 
2065: !    To terminate the algorithm, FCN may set IFLAG negative on return. 
2066: ! 
2067: !    Input, integer ( kind = 4 ) M, the number of functions. 
2068: ! 
2069: !    Input, integer ( kind = 4 ) N, is the number of variables.   
2070: !    N must not exceed M. 
2071: ! 
2072: !    Input/output, real ( kind = 8 ) X(N).  On input, X must contain an initial 
2073: !    estimate of the solution vector.  On output X contains the final 
2074: !    estimate of the solution vector. 
2075: ! 
2076: !    Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X. 
2077: ! 
2078: !    Output, real ( kind = 8 ) FJAC(LDFJAC,N), an M by N array.  The upper 
2079: !    N by N submatrix contains an upper triangular matrix R with 
2080: !    diagonal elements of nonincreasing magnitude such that 
2081: !      P' * ( JAC' * JAC ) * P = R' * R, 
2082: !    where P is a permutation matrix and JAC is the final calculated 
2083: !    jacobian.  Column J of P is column IPVT(J) of the identity matrix. 
2084: !    The lower trapezoidal part of FJAC contains information generated during 
2085: !    the computation of R. 
2086: ! 
2087: !    Input, integer ( kind = 4 ) LDFJAC, is the leading dimension of FJAC, 
2088: !    which must be no less than M. 
2089: ! 
2090: !    Input, real ( kind = 8 ) TOL.  Termination occurs when the algorithm 
2091: !    estimates either that the relative error in the sum of squares is at 
2092: !    most TOL or that the relative error between X and the solution is at 
2093: !    most TOL. 
2094: ! 
2095: !    Output, integer ( kind = 4 ) INFO, error flag.  If the user has terminated 
2096: !    execution, INFO is set to the (negative) value of IFLAG. See description 
2097: !    of FCN.  Otherwise, INFO is set as follows: 
2098: !    0, improper input parameters. 
2099: !    1, algorithm estimates that the relative error in the sum of squares 
2100: !       is at most TOL. 
2101: !    2, algorithm estimates that the relative error between X and the 
2102: !       solution is at most TOL. 
2103: !    3, conditions for INFO = 1 and INFO = 2 both hold. 
2104: !    4, FVEC is orthogonal to the columns of the jacobian to machine precision. 
2105: !    5, number of calls to FCN with IFLAG = 1 has reached 100*(N+1). 
2106: !    6, TOL is too small.  No further reduction in the sum of squares is 
2107: !       possible. 
2108: !    7, TOL is too small.  No further improvement in the approximate 
2109: !       solution X is possible. 
2110: ! 
2111:   implicit none 
2112:  
2113:   integer ( kind = 4 ), INTENT(IN) ::  ldfjac 
2114:   integer ( kind = 4 ), INTENT(IN) ::  m 
2115:   integer ( kind = 4 ), INTENT(IN) ::  n 
2116:  
2117:   real ( kind = 8 ) diag(n) 
2118:   real ( kind = 8 ) factor 
2119:   external fcn 
2120:   real ( kind = 8 ), INTENT(OUT) ::  fjac(ldfjac,n) 
2121:   real ( kind = 8 ) ftol 
2122:   real ( kind = 8 ), INTENT(OUT) ::  fvec(m) 
2123:   real ( kind = 8 ) gtol 
2124:   integer ( kind = 4 ), INTENT(OUT) ::  info 
2125:   integer ( kind = 4 ) ipvt(n) 
2126:   integer ( kind = 4 ) maxfev 
2127:   integer ( kind = 4 ) mode 
2128:   integer ( kind = 4 ) nfev 
2129:   integer ( kind = 4 ) njev 
2130:   integer ( kind = 4 ) nprint 
2131:   integer ( kind = 4 ) iflag 
2132:   real ( kind = 8 ) qtf(n) 
2133:   real ( kind = 8 ), INTENT(IN) ::  tol 
2134:   real ( kind = 8 ) x(n) 
2135:   real ( kind = 8 ) xtol 
2136:  
2137:   info = 0 
2138:  
2139:   if ( n <= 0 ) then 
2140:     return 
2141:   else if ( m < n ) then 
2142:     return 
2143:   else if ( ldfjac < m ) then 
2144:     return 
2145:   else if ( tol < 0.0D+00 ) then 
2146:     return 
2147:   end if 
2148:  
2149:   factor = 100.0D+00 
2150:   maxfev = 100 * ( n + 1 ) 
2151:   ftol = tol 
2152:   xtol = tol 
2153:   gtol = 0.0D+00 
2154:   mode = 1 
2155:   nprint = 0 
2156:  
2157:   !hack to get f2py to work, not needed for pure FORTRAN compilation 
2158:   iflag = 0 
2159:   call fcn ( m, n, x, fvec, fjac, ldfjac, iflag ) 
2160:  
2161:   call lmder ( fcn, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, maxfev, & 
2162:     diag, mode, factor, nprint, info, nfev, njev, ipvt, qtf ) 
2163:  
2164:   if ( info == 8 ) then 
2165:     info = 4 
2166:   end if 
2167:  
2168:   return 
2169: end 
2170:  
2171: function enorm ( n, x ) 
2172:  
2173: !*****************************************************************************80 
2174: ! 
2175: !! ENORM computes the Euclidean norm of a vector. 
2176: ! 
2177: !  Discussion: 
2178: ! 
2179: !    This is an extremely simplified version of the original ENORM 
2180: !    routine, which has been renamed to "ENORM2". 
2181: ! 
2182: !  Licensing: 
2183: ! 
2184: !    This code is distributed under the GNU LGPL license. 
2185: ! 
2186: !  Modified: 
2187: ! 
2188: !    06 April 2010 
2189: ! 
2190: !  Author: 
2191: ! 
2192: !    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom. 
2193: !    FORTRAN90 version by John Burkardt. 
2194: ! 
2195: !  Reference: 
2196: ! 
2197: !    Jorge More, Burton Garbow, Kenneth Hillstrom, 
2198: !    User Guide for MINPACK-1, 
2199: !    Technical Report ANL-80-74, 
2200: !    Argonne National Laboratory, 1980. 
2201: ! 
2202: !  Parameters: 
2203: ! 
2204: !    Input, integer ( kind = 4 ) N, is the length of the vector. 
2205: ! 
2206: !    Input, real ( kind = 8 ) X(N), the vector whose norm is desired. 
2207: ! 
2208: !    Output, real ( kind = 8 ) ENORM, the Euclidean norm of the vector. 
2209: ! 
2210:   implicit none 
2211:  
2212:   integer ( kind = 4 ) n 
2213:   real ( kind = 8 ) x(n) 
2214:   real ( kind = 8 ) enorm 
2215:  
2216:   enorm = sqrt ( sum ( x(1:n) ** 2 )) 
2217:  
2218:   return 
2219: end 
2220:  
2221: function enorm2 ( n, x ) 
2222:  
2223: !*****************************************************************************80 
2224: ! 
2225: !! ENORM2 computes the Euclidean norm of a vector. 
2226: ! 
2227: !  Discussion: 
2228: ! 
2229: !    This routine was named ENORM.  It has been renamed "ENORM2", 
2230: !    and a simplified routine has been substituted. 
2231: ! 
2232: !    The Euclidean norm is computed by accumulating the sum of 
2233: !    squares in three different sums.  The sums of squares for the 
2234: !    small and large components are scaled so that no overflows 
2235: !    occur.  Non-destructive underflows are permitted.  Underflows 
2236: !    and overflows do not occur in the computation of the unscaled 
2237: !    sum of squares for the intermediate components. 
2238: ! 
2239: !    The definitions of small, intermediate and large components 
2240: !    depend on two constants, RDWARF and RGIANT.  The main 
2241: !    restrictions on these constants are that RDWARF^2 not 
2242: !    underflow and RGIANT^2 not overflow. 
2243: ! 
2244: !  Licensing: 
2245: ! 
2246: !    This code is distributed under the GNU LGPL license. 
2247: ! 
2248: !  Modified: 
2249: ! 
2250: !    06 April 2010 
2251: ! 
2252: !  Author: 
2253: ! 
2254: !    Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom. 
2255: !    FORTRAN90 version by John Burkardt. 
2256: ! 
2257: !  Reference: 
2258: ! 
2259: !    Jorge More, Burton Garbow, Kenneth Hillstrom, 
2260: !    User Guide for MINPACK-1 
2261: !    Argonne National Laboratory, 
2262: !    Argonne, Illinois. 
2263: ! 
2264: !  Parameters: 
2265: ! 
2266: !    Input, integer ( kind = 4 ) N, is the length of the vector. 
2267: ! 
2268: !    Input, real ( kind = 8 ) X(N), the vector whose norm is desired. 
2269: ! 
2270: !    Output, real ( kind = 8 ) ENORM2, the Euclidean norm of the vector. 
2271