C PROGRAM "HASSP.FOR" -- SEARCHES FOR SOLUTIONS TO PATTERSON MAP. C C C BASED ON MINIMUM METHOD. SPACE-GROUP GENERAL. C C T.C.TERWILLIGER APRIL, 1982. C C VERSION 2.2 NOVEMBER, 1982 C C C C THIS FILE CONTAINS THE MAIN PROGRAM AND C 25 SUBROUTINES ARRANGED IN THE FOLLOWING ORDER: C C HASSP (MAIN PROGRAM) C INPUT (READ IN AND CHECK INPUT PARAMETERS) C MEP (READ IN ALL SYMMETRY OPERATIONS) C C MINIM (CALCULATE ALL CROSS-VECTORS FOR A GROUP OF SITES; MINIMUM FN) C ISIGNF (DETERMINE PROBABILITY A GIVEN SOLUTION IS DUE TO CHANCE) C NEW (PART OF ISIGNF, DETERMINES IF A PATT VECTOR IS NEW) C C PATPK (DETERMINE LOCATIONS OF ISOLATED PEAKS IN PATTERSON FUNCTION) C SINGLE (DETERMINE LIKELY SINGLE-SITE SOLUTIONS) C DOUBLE (DETERMINE LIKELY TWO-SITE SOLUTIONS) C TRIPLE (SEARCH FOR ADDITIONAL SITES) C SIFT (ANALYZE ADDITIONAL SITES) C C SECPK (LOCATE LOCAL MAXIMA ON A SECTION OF A MAP) C SORT (SORT A GROUP OF SITES BASED ON SYMMETRY OF THEIR POSITIONS) C SPECP (DETERMINE IF A POSITION IS A SPECIAL POSITION IN PATTERSON) C SPECR (DETERMINE IF A POSITION IS A SPECIAL POSITION IN REAL CELL) C CROSPC (DETERMINE IF CROSS VECTORS FOR A PAIR OF SITES ARE ON C SPECIAL POSITIONS) C SAMEP (DETERMINE IF TWO POSITIONS ARE EQUIVALENT BY PATTERSON SYMMETRY) C SAMER (DETERMINE IF TWO POSITIONS ARE EQUIVALENT BY SPACE-GROUP SYMM) C SAMEH (DETERMINE IF TWO POSITIONS HAVE SAME HARKER VECTORS) C C MAXIM (ADJUST LOCATIONS OF TRIAL SITES TO MAXIMIZE MINIMUM FUNCTION) C SAVEP (SAVE A LIST OF POSITIONS SORTED ON VALUE OF MINIMUM FUNCTION) C INSIDE (APPLY SPACE-GROUP SYMMETRY TO A SITE TO MOVE IT INTO SEARCH C REGION) C HARMIN (DETERMINE MINIMUM FUNCTION FOR SINGLE-SITE) C CROMIN (DETERMINE MINIMUM FUNCTION FOR MULTIPLE SITES) C SRTSIG (SORT A LIST OF SITES BASED ON LIKELIHOOD OF NOT BEING DUE C TO CHANCE) C PATT (RETURN VALUE OF PATTERSON FUNCTION AT A PARTICULAR POSITION) C C****************************************************************************** C C C C C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C C..............START HERE........ C C...GET CONTROL PARAMETERS AND PATTERSON MAP C CALL INPUT C C...LOOK FOR ISOLATED PEAKS IN PATTERSON MAP (LIKELY TO BE SINGLE-WEIGHT PEAKS) C IF(ITYPE.GE.0 .OR. NSIGNF.EQ.0)CALL PATPK ITYPE=IABS(ITYPE) C C C...LOOK FOR SINGLE-SITE SOLUTIONS TO PATTERSON BASED ON HARKER VECTORS C IF(ITYPE.EQ.2.OR.ITYPE.EQ.5)CALL SINGLE C C...LOOK FOR TWO-SITE SOLUTIONS BASED ON HARKER VECTORS AND CROSS-VECTORS C THE TWO SITES ARE ASSUMED TO BE RELATED BY A CROSS VECTOR FOUND: C (A) IN INPUT FILE OR (B) AN ISOLATED PATTERSON PEAK C C...IF ITYPE=5, FOR EACH SOLUTION, CALL SIFT AS WELL C IF(ITYPE.EQ.3.OR.ITYPE.EQ.5)CALL DOUBLE C C...LOOK FOR ALL SITES CONSISTENT (HAVING ALL CROSS-VECTORS PRESENT) WITH C TWO KNOWN SITES (FROM INPUT FILE OR RESULTS OF "DOUBLE") C IF(ITYPE.EQ.4)CALL TRIPLE(1) C C...GIVEN ONE OR MORE KNOWN SITES, GENERATE AN INTERNALLY CONSISTENT SET OF C SITES WITH ALL CROSS-VECTORS GREATER THAN OR EQUAL TO ZERO. DIFFERENT C FROM TRIPLE IN THAT TRIPLE YIELDS LIST OF SITES ALL CONSISTENT WITH C STARTING SITES, NOT WITH EACH OTHER. C IF(ITYPE.EQ.6)CALL SIFT C STOP END C SUBROUTINE INPUT C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C C...LOCAL VARIABLES C LOGICAL*1 DATEX(9),TIMDAY(8) DIMENSION AINPUT(4) C CALL TIME(TIMDAY) CALL DATE(DATEX) C CALL ASSIGN(5,'HASSP.IN') c CALL ASSIGN(6,'HASSP.PRT') C WRITE(6,10)TIMDAY,DATEX 10 FORMAT(1X,'"HASSP -- PATTERSON SEARCH AND SUPERPOSITION PROGRAM.', 1 4X,8A1,5X,9A1,//,1X,'INPUT PARAMETERS: ',/) C C...GET NAME OF FILE CONTAINING MATRICES OF EQUIVALENT POSITIONS C THESE ARE ASSUMED TO BE INPUT IN GROUPS RELATED TO EACH OTHER BY C CENTERING ALONE. C READ(5,20)NQMEP,(MEPFIL(I),I=1,NQMEP) WRITE(6,21)(MEPFIL(I),I=1,NQMEP) 20 FORMAT(Q,40A1) 21 FORMAT(1X,'MATRICES OF EQUIVALENT POSITIONS FROM: ',40A1) CALL ASSIGN(3,MEPFIL,NQMEP) C C..INPUT PATTERSON MAP C READ(5,20)NQPAT,(PATFIL(I),I=1,NQPAT) WRITE(6,22)(PATFIL(I),I=1,NQPAT) 22 FORMAT(1X,'FFT OUTPUT FROM: ',40A1) CALL ASSIGN(1,PATFIL,NQPAT) C C...CELL DIMENSIONS IN GRID UNITS, LIMITING GRID VALUES FOR PATTERSON MAP C..(ASSUMED THAT 0,0,0 ARE LOWER BOUNDS). C READ(5,30)IPCELL,NPATXE,NPATYE,NPATZE WRITE(6,23)IPCELL,NPATXE,NPATYE,NPATZE 23 FORMAT(1X,'IPCELL(1-3),NPATXE,NPATYE,NPATZE:',3I5,2X,3I5) 30 FORMAT(15I5) C C...MAKE SURE GRID BOUNDARIES ARE NOT TOO BIG OR SMALL C NX1=NPATXE+1 NY1=NPATYE+1 NZ1=NPATZE+1 IF(NX1*NY1*NZ1.GT.1800000)STOP'INPUT PATTERSON MAP IS TOO BIG' IF(NX1.LT.1.OR.NY1.LT.1.OR.NZ1.LT.1)STOP 1 ' NPATXE,NPATYE,NPATZE MUST ALL BE NON-NEGATIVE' C C...GET PATTERSON MAP C...IT MUST BE IN THE FORM: X ACROSS, Y DOWN, Z SECTIONS, WHERE X,Y,Z C CORRESPOND TO THOSE IN MATRICES OF EQUIVALENT POSITIONS. C C**************** MODIFY NEXT FEW LINES TO READ YOUR FFT OUTPUT ************ N=0 DO 31 K=1,NZ1 DO 31 J=1,NY1 READ(1,END=32)(PATTER(INDX),INDX=N+1,N+NX1) 31 N=N+NX1 GO TO 33 32 STOP'INPUT FILE FOR PATTERSON MAP HAS INSUFFICIENT NUMBER OF DATA' 33 CONTINUE C*************************************************************************** C C...GET PARAMETERS FOR SEARCH OR MAP. NXS,NXE ARE STARTING AND ENDING GRID C POINTS FOR SEARCH IN X-DIRECTION (ACROSS) C C READ(5,42)ANXS,ANXE,ANYS,ANYE,ANZS,ANZE WRITE(6,43)ANXS,ANXE,ANYS,ANYE,ANZS,ANZE 43 FORMAT(1X,'XS,XE,YS,YE,ZS,ZE: ',3(2F6.3,2X) ) 42 FORMAT(6F10.0) NXS=INT(ANXS*FLOAT(IPCELL(1)*2) +0.5) NXE=INT(ANXE*FLOAT(IPCELL(1)*2) +0.5) NYS=INT(ANYS*FLOAT(IPCELL(2)*2) +0.5) NYE=INT(ANYE*FLOAT(IPCELL(2)*2) +0.5) NZS=INT(ANZS*FLOAT(IPCELL(3)*2) +0.5) NZE=INT(ANZE*FLOAT(IPCELL(3)*2) +0.5) C C...FILE CONTAINING NON-CRYSTALLOGRAPHIC SYMMETRY C C...NQNCR WILL BE USED AS THE FLAG FOR NON-CRYST. SYMMETRY (IT IS IN IF C NQNCR IS NON-ZERO) C READ(5,20,END=1001)NQNCR,(NCRFIL(I),I=1,NQNCR) 1001 IF(NQNCR.NE.0)WRITE(6,24)(NCRFIL(I),I=1,NQNCR) 24 FORMAT(1X,'NON-CRYSTALLOGRAPHIC SYMMETRY FROM: ',40A1) IF(NQNCR.NE.0)CALL ASSIGN(4,NCRFIL,NQNCR) IF(NQNCR.EQ.0)WRITE(6,25) 25 FORMAT(1X,'NO NON-CRYSTALLOGRAPHIC SYMMETRY USED') C...CALCULATE USEFUL MULTIPLES OF CELL DIMENSIONS C DO 120 L=1,3 ICELL(L)=2*IPCELL(L) C ILARG(L)=1000*ICELL(L) 120 IF(ICELL(L).LT.1 .OR. ICELL(L).GT.1000)STOP'CELL DIMENSIONS <1 1 OR > 1000 FOUND' C C C...GET MAX NO. OF PEAKS TO WORK WITH, BOX SIZE AND DISCRIMINATION FACTOR C (SEE BELOW),MAXIMUM NUMBER OF CROSS VECTORS TO USE IN SEARCHES, C AND FLAG FOR IGNORING DIFFERENCE BETWEEN GENERAL AND C SPECIAL POSITIONS C READ(5,35,END=1002)DISCRM,ICRMAX,NOSPEC 1002 WRITE(6,36)DISCRM,ICRMAX,NOSPEC 36 FORMAT(1X,'DISCRM,ICRMAX,NOSPEC: ',F10.3,2I5) 35 FORMAT(F10.0,2I5) C IF(ICRMAX.EQ.0)ICRMAX=1 NBOX=4 C C...GET CONTROL PARAMETERS: C C....ITYPE= > -1 ...GET ISOLATED PATTERSON PEAKS C 2 OR -2 ...SEARCH FOR SINGLE-SITE SOLUTIONS USING HARKER VECTORS C 3 OR -3 ...SEARCH FOR 2-SITE (PLUS SPACE-GROUP SYMMETRY-RELATED C SITES) SOLUTIONS USING ENTIRE PATTERSON. TWO SITES C ARE RELATED BY A CROSS VECTOR FOUND IN PATTERSON C (ITYPE=3) OR INPUT (ITYPE=-3) C -4 ...SEARCH FOR SITES CONSISTENT WITH 2 INPUT SITES C 5 OR -5 ...DO # 3 OR -3, THEN DO #6 FOR EACH 2-SITE SOLUTION C -6 ...GENERATE INTERNALLY CONSISTENT SET OF SITES C GIVEN ONE OR MORE-SITE STARTING SOLUTION C READ(5,30,END=1003)ITYPE,IMAP 1003 WRITE(6,37)ITYPE,IMAP 37 FORMAT(1X,'ITYPE, IMAP',2I6) C IF(ITYPE.EQ.0)ITYPE=5 C IF((IABS(ITYPE).GT.6).OR.(ITYPE.EQ.4) .OR.( ITYPE.EQ.6) 1 .OR. (IABS(ITYPE).EQ.1) )STOP 1 'ILLEGAL VALUE FOR ITYPE' C C...GET INFORMATION FOR SIGNIFICANCE TESTS ON PEAKS. C READ(5,98,END=1006)NSIGNF,SPAT,SSIN,SDUB,STRP,SSFT 1006 WRITE(6,48)NSIGNF,SPAT,SSIN,SDUB,STRP,SSFT 48 FORMAT(1X,'NSIGNF',6X,'SPAT',6X,'SSIN',6X,'SDUB',6X, 1 'STRP',6X,'SSFT', 1 /,1X,I3,1X,1X,6F10.3) 98 FORMAT(I10,6F10.0) IF(NSIGNF.NE.0)NSIGNF=1 IF(SPAT.LE.0.)SPAT=0. IF(SPAT.GT.1.)SPAT=1.0 IF(SSIN.LE.0.)SSIN=0.0 IF(SSIN.GT.1.)SSIN=1.0 IF(SDUB.LE.0.)SDUB=0.95 IF(SDUB.GT.1.)SDUB=1.0 IF(STRP.LE.0.)STRP=0. IF(STRP.GT.1.)STRP=1. IF(SSFT.LE.0.)SSFT=0.95 IF(SSFT.GT.1.)SSFT=1.0 C C C..IF TWO-ATOM SEARCH IS TO BE DONE AND ITST<0, NEED TRIAL CROSS-VECTORS C RELATING TWO ATOMS. THEY ARE TRIED OUT ONE AT A TIME. C IF(ITYPE.NE.-3.AND.ITYPE.NE.-5)GO TO 87 C WRITE(6,81) 81 FORMAT(1X,'LIST OF INPUT TRIAL CROSS-VECTORS FOR TWO-ATOM SEARCH:',/, 1 3X,'PEAK',9X,'X',9X,'Y',9X,'Z',9X,'WEIGHT',/) C NCROSS=0 85 READ(5,61,END=87)AINPUT 61 FORMAT(4F10.0) NCROSS=NCROSS+1 IF(NCROSS.GT.100)STOP' MAXIMUM OF 100 TRIAL CROSS VECTORS ALLOWED' WRITE(6,62)NCROSS,AINPUT 62 FORMAT(1X,I6,3F10.3,G15.5) DO 86 L=1,3 86 ICROSS(L,NCROSS)=JINT(0.5+AINPUT(L)*FLOAT(ICELL(L)) ) PCROSS(NCROSS)=AINPUT(4) IF(PCROSS(NCROSS).LE.0.)PCROSS(NCROSS)=1.0 GO TO 85 C C...IF DESIRED, READ IN SET OF SITES ALREADY KNOWN TO BE SELF-CONSISTENT C TO BE USED AS STARTING POINT FOR SEARCH FOR OTHER SITES. C 87 IF(ITYPE.NE.-4 .AND. ITYPE.NE.-6)GO TO 100 C WRITE(6,95) 95 FORMAT(1X,'LIST OF KNOWN SITES USED IN SEARCH FOR MORE SELF', 1 '-CONSISTENT SITES',/, 1 3X,'SITE',9X,'X',9X,'Y',9X,'Z',9X,'WEIGHT',/) C NSOLN=0 88 READ(5,61,END=100)AINPUT NSOLN=NSOLN+1 IF(NSOLN.GT.40)STOP'MAXIMUM OF 40 SOLUTIONS ALLOWED' WRITE(6,62)NSOLN,AINPUT DO 89 L=1,3 89 ISOLN(L,NSOLN)=JINT(0.5+AINPUT(L)*FLOAT(ICELL(L)) ) WSOLN(NSOLN)=AINPUT(4) IF(WSOLN(NSOLN).LE.0)WSOLN(NSOLN)=1.0 C GO TO 88 C 100 CONTINUE C C..GET MATRICES OF EQUIVALENT POSITIONS, HARKER VECTORS, ETC. C CALL MEP C C..SET TOLERANCES IN GRID UNITS. C C...NTOL4 IS FOR COMPARISONS OF LOCATIONS OF TWO PEAKS -- THEY CANNOT C BE CLOSER THAN 4 GRID UNITS (ON FINE GRID=ICELL) IN ANY DIRECTION. C C...NTOL2 IS FOR DETERMINING WHETHER A POINT IS ON A SPECIAL POSITION -- C IT IS IF AN EQUIVALENT IS WITHIN 2 GRID UNITS OF IT. C NTOL4=4 NTOL2=2 C C IF(NSIGNF.EQ.0)WRITE(6,97)SPAT,SSIN,SDUB,STRP,SSFT 97 FORMAT('1',/,1X,'SIGNIFICANCE TESTS WILL BE CARRIED OUT ON PEAKS.' 1 ,/,1X, 1 1X,'MINIMUM PROBABILITY', 1 ' THAT PEAK IS NON-', 1 'RANDOM REQUIRED TO KEEP IT:',/,1X,'PATTERSON PEAKS: ',F5.2,/,1X, 1 'SINGLE-ATOM SEARCHES: ',F5.2,/,1X,'ORIGIN-SEARCHES: ',F5.2,/,1X, 1 'GENERAL SEARCHES: ',F5.2,/,1X,'SIFT: ',F5.2,/) IF(NSIGNF.EQ.1)WRITE(6,96) 96 FORMAT(1X,'NO SIGNIFICANCE TESTS WILL BE DONE ON PEAKS.') C WRITE(6,101)NX1,0,NPATXE,IPCELL(1),NY1,0,NPATYE,IPCELL(2), 1 NZ1,0,NPATZE,IPCELL(3) C 101 FORMAT(/,1X,'INPUT PATTERSON MAP HAS: ',/, 1 I3,' GRID POINTS ACROSS, FROM ',I3,' TO ',I3,' WHERE CELL TRANS' 2 'LATION IS ',I3,' GRID UNITS',/, 1 I3,' GRID POINTS DOWN, FROM ',I3,' TO ',I3,' WHERE CELL TRANS' 2 'LATION IS ',I3,' GRID UNITS',/, 1 I3,' SECTIONS,',10X,' FROM ',I3,' TO ',I3,' WHERE CELL TRANS' 2 'LATION IS ',I3,' SECTIONS',/) C 111 FORMAT(/,1X,'PATTERSON INPUT FILE IS: ',40A1) C C IF(DISCRM.LE.0.)DISCRM=1.5 C WRITE(6,121)2*NBOX+1,DISCRM,ICRMAX 121 FORMAT(1X,'"ISOLATED PEAKS" WILL',/, 1 1X,'BE THOSE WHICH HAVE A BOX OF GRID POINTS',I4,' GRID UNITS ', 1 'OR LESS ON A SIDE,',/,' CENTERED AT' 1,' THE PEAK, ON WHICH ALL VALUES ARE 1/',F5.3,' * ', 1 ' PEAK HEIGHT OR LESS.',//, 1 ',MAXIMUM NUMBER OF CROSS PEAKS TO TRY IN SEARCHES:',I5,/) C IF(NOSPEC.NE.0)WRITE(6,122) 122 FORMAT(1X,'DIFFERENCES BETWEEN GENERAL AND SPECIAL POSITIONS', 1 ' WILL BE IGNORED.',/) C NX=(NXE-NXS)/2+3 NY=(NYE-NYS)/2+3 NZ=(NZE-NZS)/2+1 IF(NX.LT.1.OR.NY.LT.1.OR.NZ.LT.1)STOP'ILLEGAL SEARCH AREA' C IF(NX*NY.GT.40000)STOP'GRID SEARCH AREA IN X,Y IS TOO LARGE 1 MAXIMUM IS 40000 GRID POINTS' C 150 WRITE(6,151)NX-2,NXS/2,NXE/2,IPCELL(1),NY-2,NYS/2,NYE/2,IPCELL(2), 1 NZ,NZS/2,NZE/2,IPCELL(3) 151 FORMAT(1X,'SEARCH REGION AND OUTPUT MAP HAVE: ',/, 1 1X,I3,' GRID POINTS ACROSS, FROM ',I3,' TO ',I3,' WHERE CELL TRANS' 2 'LATION IS ',I3,' GRID UNITS',/, 1 1X,I3,' GRID POINTS DOWN, FROM ',I3,' TO ',I3,' WHERE CELL TRANS' 2 'LATION IS ',I3,' GRID UNITS',/, 1 1X,I3,' SECTIONS,',10X,' FROM ',I3,' TO ',I3,' WHERE CELL TRANS' 2 'LATION IS ',I3,' SECTIONS',/) C C WRITE(6,155)(NTOL4/FLOAT(ICELL(L)),L=1,3) 155 FORMAT(1X,'PEAKS REPORTED IN SEARCHES ', 1 ' WILL BE SEPARATED BY ',F5.3, 1 ' IN X,',F5.3,' IN Y, OR ',F5.3,' IN Z',/ 1 ' PAIRS OF PEAKS SEPARATED BY LESS THAN HALF THESE ', 1 'TOLERANCES WILL BE CONSIDERED OVERLAPPING',/) C C 200 IF(IABS(ITYPE).NE.2 .AND. IABS(ITYPE).NE.5)GO TO 210 WRITE(6,201) 201 FORMAT(1X,'SINGLE-ATOM HARKER SEARCH WILL BE PERFORMED.') IF(IABS(ITYPE).EQ.2)GO TO 5000 C 210 IF(IABS(ITYPE).NE.3)GO TO 250 WRITE(6,211) 211 FORMAT(1X,'TWO-SITE SEARCH WILL BE PERFORMED.') IF(ITYPE.EQ.3)WRITE(6,212) 212 FORMAT(1X,'ISOLATED PEAKS FOUND IN PATTERSON WILL BE USED' 1 ' AS TRIAL CROSS-VECTORS IN SEARCH.') IF(ITYPE.EQ.-3)WRITE(6,213) 213 FORMAT(1X,'CROSS-VECTORS FOR THIS SEARCH WILL BE READ FROM', 1' INPUT FILE.') C GO TO 5000 250 IF(IABS(ITYPE).NE.4)GO TO 275 WRITE(6,251) 251 FORMAT(1X,'SITES CONSISTENT WITH SUPPLIED SITES WILL BE FOUND.') GO TO 5000 C 275 IF(IABS(ITYPE).NE.5)GO TO 285 WRITE(6,276) 276 FORMAT(1X,' CONSISTENT SETS OF SITES WILL BE GENERATED', 1 1X,'BASED ON TWO-SITE SOLUTIONS.') GO TO 5000 C 285 IF(IABS(ITYPE).NE.6)STOP'ERROR' WRITE(6,286) 286 FORMAT(1X,'SET OF CONSISTENT SITES WILL BE GENERATED',/, 1 1X,'FROM SUPPLIED SITES') GO TO 5000 5000 CALL CLOSE(5) C C...GENERATE NON-CRYSTALLOGRAPHICALLY RELATED SITES TO INPUT SITES C IF ITYPE=-4 OR -6 C IF(ITYPE.NE.-4 .AND.ITYPE.NE.-6)GO TO 5001 C NMIN=0 NCUR=1 DO 5020 I=1,NSOLN NMIN=NMIN+1 IF(NMIN.GT.200)STOP'NUMBER OF SOLNS*NUMBER OF EQUIV 1 POSITIONS EXCEEDS 200' IMIN(NCUR)=ISOLN(1,I) JMIN(NCUR)=ISOLN(2,I) KMIN(NCUR)=ISOLN(3,I) 5020 NCUR=NCUR+NEQUIV CALL MINIM(-1,RHO) C C..NOW MOVE THEM INTO ISOLN. C IF(NMIN.EQ.NSOLN)GO TO 5026 NS=NSOLN NCUR=NSOLN*NEQUIV+1 DO 5025 I=NSOLN+1,NMIN NS=NS+1 IF(NS.GT.100)STOP'TOO MANY SOLUTIONS INPUT' ISOLN(1,NS)=IMIN(NCUR) ISOLN(2,NS)=JMIN(NCUR) ISOLN(3,NS)=KMIN(NCUR) WSOLN(NS)=1. 5025 NCUR=NCUR+NEQUIV NSOLN=NS C C..MAKE SURE ALL SITES ARE UNIQUE C 5026 NS=1 DO 5030 I=2,NSOLN DO 5028 J=1,NS CALL SAMER(ISOLN(1,J),ISOLN(2,J),ISOLN(3,J), 1 ISOLN(1,I),ISOLN(2,I),ISOLN(3,I),ISAME) 5028 IF(ISAME.EQ.1)GO TO 5030 C C..THESE ARE DIFFERENT C NS=NS+1 C C...PUT IT IN ASYMMETRIC UNIT C CALL INSIDE(ISOLN(1,I),ISOLN(2,I),ISOLN(3,I)) C DO 5029 L=1,3 5029 ISOLN(L,NS)=ISOLN(L,I) WSOLN(NS)=WSOLN(I) 5030 CONTINUE NSOLN=NS C C...WRITE OUT LIST OF SOLUTIONS USED IN SEARCH FOR MORE SOLUTIONS. C WRITE(6,5040)(I,(FLOAT(ISOLN(L,I))/FLOAT(ICELL(L)),L=1,3), 1 I=1,NSOLN) C 5040 FORMAT(//,1X,'LIST OF UNIQUE + NON-CRYSTALLOGRAPHICALLY ', 1 'RELATED SITES USED',/,1X,'IN SEARCH FOR ADDITIONAL SITES:', 1 //,3X,'PEAK',9X,'X',9X,'Y',9X,'Z',/,(1X,I6,3F10.3)) C C 5001 WRITE(6,5003) 5003 FORMAT('1') RETURN END SUBROUTINE MEP C C FUNCTION: C C...READ IN EQUIVALENT POSITIONS FROM FILE, SEPARATE CENTERED GROUPS. C THEN DETERMINE PATTERSON SYMMETRY AND UNIQUE SET OF HARKER VECTORS. C C...ALSO READ IN NON-CRYSTALLOGRAPHIC SYMMETRY ELEMENTS, IF ANY. C...ALSO DIVIDE UNIT CELL INTO ABOUT 1024 SMALL BOXES. FOR EACH BOX, C DETERMINE WHICH PATTERSON SYMMETRY ELEMENT WILL MAP CENTER OF BOX C INTO ASYMMETRIC UNIT OF PATTERSON. ALSO DETERMINES WHICH LOCAL SYMMETRY C ELEMENTS ARE APPLICABLE IN THIS BOX. C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C C...LOCAL VARIABLES C DIMENSION JCENT(4),ITMP(3),ITST(3),IEQUIV(3), 1 IBOUND(2,3,24),ABOUND(2,3,24) DATA NCENTR /1/ C C C C....MATRICES OF EQUIVALENT POSITIONS ARE READ FROM A FILE WITH THE C....FOLLOWING DATA (ALL FORMATTED): C C C RECORD 1: NEQUIV (FORMAT: I3) NUMBER OF EQUIVALENT POSITIONS C NEXT (NEQUIV) RECORDS : C C R11 R21 R31 R12 R22 R32 R13 R23 R33 T1 T2 T3 C C WHERE AN EQUIV POSITION (X',Y',Z') IS RELATED TO A STARTING C POSITION (X,Y,Z) BY : C C X' / R11 R12 R13 \ X T1/12. C | | C Y' = | R21 R22 R23 | Y + T2/12. C | | C Z' \ R31 R32 R33 / Z T3/12. C C C C....R11 R21 ETC.. AND T1,T2,T3 ARE ALL READ IN AS INTEGERS (I3) C C.............................................................................. C C...READ IN NUMBER EQUIVALENT POSITIONS IN UNIT CELL, ROTATIONS & TRANSLATIONS C RELATING THEM. C READ(3,9060)NEQUIV 9060 FORMAT(I3) IF(NEQUIV.GT.24)STOP'ONLY 24 EQUIV POSITIONS ALLOWED' DO 40 K = 1, NEQUIV 40 READ (3,9020) ((IROT(I,J,K),I = 1,3),J = 1,3),(ITRANS(L,K),L=1,3) 9020 FORMAT(12I3) C C C... CLOSE MEP FILE C CALL CLOSE(3) C DO 50 K = 1, NEQUIV DO 50 J = 1, 3 50 ITRANS(J,K)=(ITRANS(J,K)*ICELL(J))/12 C C...FIND ANY CENTERING IN THESE EQUIVALENT POSITIONS C C...IT IS ASSUMED THAT THE EQUIVALENT POSITIONS ARE INPUT IN GROUPS C RELATED ONLY BY CENTERING AND THAT WITHIN GROUPS THE ROTATION C MATRICES ARE ALWAYS IN THE SAME ORDER. C ICE=1 JCENT(1)=0 ICC=0 DO 250 IPOS=2,NEQUIV C C...CHECK TO SEE IF A ROTATION MATRIX IS IDENTICAL TO # 1 C DO 240 I=1,3 DO 240 J=1,3 240 IF(IROT(I,J,IPOS).NE.IROT(I,J,1))GO TO 250 C C C...NOW CHECK THAT TRANSLATIONS ARE MULTIPLES OF 1/2 or 1/3: C IF(ICC.EQ.2)GO TO 244 DO 243 I=1,3 243 IF(JMOD(ITRANS(I,IPOS)-ITRANS(I,1),ICELL(I)/3).NE.0)GO TO 244 ICC=3 GO TO 246 244 IF(ICC.EQ.3)GOTO 250 DO 245 I=1,3 245 IF(JMOD(ITRANS(I,IPOS)-ITRANS(I,1),ICELL(I)/2) .NE. 0)GO TO 250 C ICC=2 246 CONTINUE C...IF HERE THEN THIS EQUIV POSITION IS RELATED TO #1 BY SIMPLE C...TRANSLATION OF MULTIPLES OF (1/2,1/2,1/2) OR (1/3,1/3,1/3) C ICE=ICE+1 JCENT(ICE)=IPOS-1 C C...POSITION 1+JCENT(ICE) IS EQUIV TO POS 1 EXCEPT FOR TRANSLATION C 250 CONTINUE C IF(ICE.EQ.1)GO TO 300 C C...IF ONLY ONE SET, NOTHING UNUSUAL HAPPENS C C C...WE HAVE ASSUMED THAT MATRICES ARE INPUT IN GROUPS WITH THE SAME C...CENTERING. NOW MAKE SURE THAT THIS IS SO. C NPOS1=NEQUIV/ICE IF(NPOS1*ICE.NE.NEQUIV)GO TO 300 C C... IF ICE IS NOT A DIVISOR OF NEQUIV, THEN THIS SIMPLE TEST FOR CENTERING C....DIDN'T WORK C DO 280 II=1,ICE IF(JCENT(II).NE. (II-1)*NPOS1)GO TO 300 C C...THIS INSURES THAT GROUPS ALL HAVE NPOS1 MEMBERS C C DO 280 IPOS=1,NPOS1 C C C...CHECK THAT ALL MEMBERS OF A GROUP ARE PROPERLY RELATED TO MEMBERS OF C...GROUP #1 C DO 270 I=1,3 DO 265 J=1,3 C C...ROTATION MATRICES FOR POSITION IPOS IN EACH GROUP ARE THE SAME C 265 IF(IROT(I,J,IPOS+JCENT(II)).NE.IROT(I,J,IPOS) )GO TO 300 C C C...TRANSLATION MATRICES WITHIN A GROUP MUST DIFFER ONLY BY INTEGERS C 270 IF(JMOD( ITRANS(I,IPOS+JCENT(II))-ITRANS(I,IPOS) 1 -(ITRANS(I,1+JCENT(II)) -ITRANS(I,1)), ICELL(I)) .NE.0) 1 GO TO 300 280 CONTINUE C C C...IF WE GET HERE, THEN ALL IS OK. C NCENTR=ICE NEQUIV=NPOS1 C C...RECORD THE CENTERING TRANSLATIONS C DO 290 I=1,NCENTR DO 290 L=1,3 290 ICENTR(L,I)=ITRANS(L,1+(I-1)*NPOS1)-ITRANS(L,1) C C C...WRITE OUT THE TRANSLATION RELATIONS C WRITE(6,9000)NCENTR,NEQUIV 9000 FORMAT(//,' THIS SPACE GROUP HAS ',I3,' SETS OF ', 1 I3,' IDENTICAL GROUPS', 1 /,' OF EQUIVALENT POSITIONS RELATED BY CENTERING TRANSLATIONS:' 1 ,/) C DO 350 I=2,NCENTR 350 WRITE(6,9005)I,(FLOAT(ICENTR(L,I))/FLOAT(ICELL(L)),L=1,3) C 9005 FORMAT(' GROUP ',I1,' IS RELATED TO GROUP 1 BY', 1 ' THE TRANSLATION: (',F5.3,',',F5.3,',',F5.3,')') 300 CONTINUE C WRITE(6,9070)NEQUIV 9070 FORMAT(//,' THE FUNDAMENTAL SET OF',I3,' ROTATION MATRICES AND' 1 ' TRANSLATION VECTORS FOR THIS SPACE GROUP IS: ',//) C C C...WRITE OUT EQUIVALENT POSITIONS C KM = NEQUIV KI = 1 KE = 0 60 CONTINUE KE = MIN0(KM,4) + KE DO 70 I = 1, 3 70 WRITE(6,9030)((IROT(I,J,K),J=1,3),FLOAT(ITRANS(I,K)) 1 /FLOAT(ICELL(I)) 1 ,K=KI,KE) 9030 FORMAT(4(3I3,2X,F5.3,8X)) 9031 FORMAT(4(3I3,2X,3X,10X)) KI = KI + 4 KM = KM - 4 WRITE (6, 9040) 9040 FORMAT() IF (KM) 80,80,60 80 CONTINUE C C...MAKE SURE IDENTITY IS FIRST C DO 85 I=1,3 IF(ITRANS(I,1).NE.0)GO TO 86 DO 85 J=1,3 IF(I.EQ.J)GO TO 84 IF(IROT(I,J,1).NE.0)GO TO 86 GO TO 85 84 IF(IROT(I,J,1).NE.1)GO TO 86 85 CONTINUE GO TO 87 86 STOP 'FIRST EQUIVALENT POSITION MUST BE IDENTITY.' 87 CONTINUE C C...GET PATTERSON SYMMETRY OPERATORS C...THESE ARE ALL ROTATION MATRICES + INVERSE IN UNIQUE SYMMETRY GROUP C NPROT=0 DO 1000 I=1,NEQUIV IF(NPROT.EQ.0)GO TO 460 DO 450 J=1,NPROT DO 425 L1=1,3 DO 425 L2=1,3 425 IF(IROT(L1,L2,I).NE.IPROT(L1,L2,J))GO TO 450 GO TO 1000 450 CONTINUE 460 CONTINUE C C..DONE DO 475 L1=1,3 DO 475 L2=1,3 IPROT(L1,L2,NPROT+1)=IROT(L1,L2,I) IPROT(L1,L2,NPROT+2)= - IROT(L1,L2,I) 475 CONTINUE NPROT=NPROT+2 1000 CONTINUE C C...NOTE THAT THE PATTERSON ROTATION MATRICES ARE IN SETS OF TWO, RELATED C BY INVERSION. C C...GET CENTERING VECTORS FOR PATTERSON CELL (1/2 THE GRID OF REAL CELL) C DO 476 I=1,24 DO 476 L=1,3 476 IPCEN(L,I)=ICENTR(L,I)/2 C C...ALL DONE C WRITE(6,1001)NPROT 1001 FORMAT(//,1X,'(ASIDE FROM CENTERING, IF ANY) THERE ARE', 1 I3,' EQUIVALENT', 1 ' POSITIONS IN THE PATTERSON FUNCTION:',/) KM = NPROT KI = 1 KE = 0 1060 CONTINUE KE = MIN0(KM,4) + KE DO 1070 I = 1, 3 1070 WRITE(6,9031)((IPROT(I,J,K),J=1,3),K=KI,KE) KI = KI + 4 KM = KM - 4 WRITE (6, 9040) IF (KM) 1080,1080,1060 1080 CONTINUE C C...GET UNIQUE HARKER VECTORS, WHICH ARE SIMPLY DIFFERENCES BETWEEN EACH C...EQUIVALENT POSITION IN UNIQUE GROUP AND THE IDENTITY. C NHARK=0 DO 1096 I=2,NEQUIV NN=NHARK+1 DO 1050 L1=1,3 DO 1050 L2=1,3 1050 IHARKR(L1,L2,NN)=IROT(L1,L2,1)-IROT(L1,L2,I) DO 1055 L1=1,3 1055 IHARKT(L1,NN)=JMOD(ITRANS(L1,1)-ITRANS(L1,I)+ILARG(L1),ICELL(L1)) C C...NOW TEST TO MAKE SURE THIS HARKER VECTOR IS ACTUALLY DIFFERENT THAN C ALL PREVIOUS ONES (BY PATTERSON SYMMETRY). C IF(NHARK.EQ.0)GO TO 1095 DO 1081 JJ=1,NHARK C C...IS THIS OLD HARKER VECTOR SAME AS NEW ONE? C DO 1081 K=1,NPROT C C...BY THIS ROTATION OPERATION..? C DO 1057 L=1,3 INDX=0 DO 1056 LL=1,3 1056 INDX=INDX+IPROT(L,LL,K)*IHARKT(LL,JJ) 1057 ITMP(L)=INDX C C...WITH THIS CENTERING? C DO 1081 KK=1,NCENTR DO 1058 L=1,3 1058 IF(JMOD(ITMP(L)+ICENTR(L,KK)+ILARG(L),ICELL(L)) 1 .NE. IHARKT(L,NN))GO TO 1081 C C..IF WE GET HERE, THE TRANSLATIONS ARE THE SAME. NOW THE ROT. C DO 1071 L=1,3 DO 1071 M=1,3 INDX=0 DO 1061 LL=1,3 1061 INDX=INDX+IPROT(L,LL,K)*IHARKR(LL,M,JJ) 1071 IF(INDX.NE.IHARKR(L,M,NN))GO TO 1081 C C...HERE THE NEW ROTATION MATRIX AND TRANSLATION ARE IDENTICAL C TO AN OLD ONE BY PATTERSON SYMMETRY. SKIP IT. C GO TO 1096 1081 CONTINUE C C..HERE THE NEW ONE IS TOTALLY DIFFERENT THAN ANY OLD ONES. KEEP IT. C 1095 NHARK=NHARK+1 1096 CONTINUE C C WRITE(6,1062)NHARK 1062 FORMAT(/,1X,'THERE ARE ',I2,' UNIQUE HARKER VECTORS: ',/) C KM = NHARK KI = 1 KE = 0 2060 CONTINUE KE = MIN0(KM,4) + KE DO 2070 I = 1, 3 2070 WRITE(6,9030)((IHARKR(I,J,K),J=1,3),FLOAT(IHARKT(I,K)) 1 /FLOAT(ICELL(I)) 1 ,K=KI,KE) KI = KI + 4 KM = KM - 4 WRITE (6, 9040) IF (KM) 2080,2080,2060 2080 CONTINUE C C C C...DIVIDE UNIT CELL UP INTO <1024 BOXES; IDIV(1-3) IS DIVISOR OF CELL EDGES C USED TO MAKE UP THE BOXES. C...FOR EACH BOX, DETERMINE WHICH C PATTERSON ROTATION MATRIX AND CENTERING WILL PLACE THIS COORDINATE C INTO ASYMMETRIC UNIT OF PATTERSON. RECORD THIS OPERATION IN C ARRAY IOPER(1-1024). IF NO CENTERING IOPER(J)=#OF OPERATION TO USE, C IF CENTERING OPERATION K, IOPER(J)=(K-1)*NEQUIV+#OF OPERATION TO USE. C C..USE SAME BOXES TO RECORD NON-CRYSTALLOGRAPHIC SYMMETRY OPERATIONS C VALID FOR THIS POINT. C C...ALWAYS DIVIDE BY 2 DO 3 L=1,3 3 IDIV(L)=2 C...TRY TO DIVIDE BY 2 AND 3 AGAIN DO 10 N23=2,3 DO 10 L=1,3 IF(JMOD(ICELL(L)/IDIV(L),N23).NE.0)GO TO 10 IDIV(L)=IDIV(L)*N23 10 CONTINUE 25 NPOS=1 DO 30 L=1,3 IF(JMOD(ICELL(L),IDIV(L)).NE.0)STOP'ERROR IN NPOS' 30 NPOS=NPOS*(ICELL(L)/IDIV(L)) IF(NPOS.LE.1024)GO TO 100 C C...THIS SET OF DIVISORS STILL IS TOO FINE. C C...TRY TO INCREASE ONE IDIV(1-3) BY A FACTOR OF A SMALL INTEGER C SUCH THAT ALL 3 IDIV(1-3) ARE STILL DIVISORS OF CELL EDGES AND C THE RATIO OF SMALLEST IDIV TO LARGEST IDIV IS AS CLOSE TO 1 AS POSSIBLE C RBEST=1.E+30 J0=10000 DO 400 L=1,3 N=ICELL(L)/IDIV(L) IF(N.EQ.1)GO TO 400 DO 35 J=2,N IF(JMOD(N,J).NE.0)GO TO 35 JBEST=J C C...JBEST IS SMALLEST INTEGER GREATER THAN 1 SUCH THAT IDIV(L)*JBEST IS A C DIVISOR OF ICELL(L) C GO TO 36 35 CONTINUE JBEST=N 36 IIMIN=100000 IIMAX=0 DO 38 LL=1,3 NN=IDIV(LL) IF(LL.EQ.L)NN=NN*JBEST IF(NN.LT.IIMIN)IIMIN=NN 38 IF(NN.GT.IIMAX)IIMAX=NN R=FLOAT(IIMAX)/FLOAT(IIMIN) IF(R.GE.RBEST)GO TO 400 LBEST=L J0=JBEST RBEST=R 400 CONTINUE IDIV(LBEST)=IDIV(LBEST)*J0 GO TO 25 C C 100 CONTINUE C C...NOW READ IN NON-CRYSTALLOGRAPHIC SYMMETRY IF ANY IS TO BE USED C...FORMAT IS SAME AS FOR CRYSTALLOGRAPHIC SYMMETRY EXCEPT ALL ARE READ C IN AS REAL NUMBERS. ALSO BOUNDARIES FOLLOW EACH SET. C IF(NQNCR.EQ.0)GO TO 801 C C WRITE(6,802) 802 FORMAT('1',//,1X,'POSITIONS EQUIVALENT BY NON-CRYSTALLOGRAPHIC', 1 ' SYMMETRY (EXCLUDING IDENTITY):' 1 ,//,1X,'OPERATION:',50X,'VALID IN THE REGION: ',/, 1 61X, ' (INPUT REGION ABOVE, FOLLOWED',/,61X, 1 ' BY REGION ACTUALLY USED, BELOW)',/, 1 58X,'XMIN',2X,'XMAX',6X,'YMIN',2X,'YMAX',6X,'ZMIN',2X,'ZMAX') C READ(4,9060)NNCR IF(NNCR.GT.24)STOP'ONLY 24 NON-CRYST POSITIONS ALLOWED' K=0 DO 820 KKK=1,NNCR K=K+1 READ(4,805)((AROT(I,J,K),I=1,3),J=1,3),(ATRAN(L,K),L=1,3) 805 FORMAT(12F6.0) READ(4,805)((ABOUND(I,L,K),I=1,2),L=1,3) C C...MAKE SURE THIS EQUIVALENT POSITION IS NOT THE IDENTITY C DO 810 I=1,3 IF(AMOD(ATRAN(I,K),1.0).NE.0.0)GO TO 811 DO 810 J=1,3 IF(I.EQ.J .AND.AROT(I,J,K).NE.1.0)GO TO 811 IF(I.NE.J .AND.AROT(I,J,K).NE.0.0)GO TO 811 810 CONTINUE K=K-1 GO TO 820 C 811 CONTINUE C C..FIGURE OUT THE CLOSEST BOUNDARY OF BOXES IDIV(1-3) ON A SIDE WHICH C LIES NEAR EACH ABOUND C C DO 815 L=1,3 DO 815 I=1,2 IBOUND(I,L,K)=IDIV(L)*(INT(ABOUND(I,L,K)*FLOAT(ICELL(L))+ 1 FLOAT(IDIV(L))/2. )/IDIV(L) ) 815 CONTINUE C C WRITE(6,821)(AROT(1,J,K),J=1,3),ATRAN(1,K), 1 ((ABOUND(I,L,K),I=1,2),L=1,3), 1 (AROT(2,J,K),J=1,3),ATRAN(2,K), 1 (AROT(3,J,K),J=1,3),ATRAN(3,K), 1 ((FLOAT(IBOUND(I,L,K))/FLOAT(ICELL(L)),I=1,2),L=1,3) C DO 820 L=1,3 820 ATRAN(L,K)=ATRAN(L,K)*FLOAT(ICELL(L)) C NNCR=K C C 821 FORMAT(//,1X,3F10.3,5X,F10.3,10X,3(2F6.3,5X), 1 /,1X,3F10.3,5X,F10.3, 1 /,1X,3F10.3,5X,F10.3,10X,3(2F6.3,5X)) C C...AROT,ATRAN ARE ROTATION AND TRANSLATION MATRICES; ABOUND(I,L) ARE C BOUNDARIES WITHIN WHICH THIS OPERATION IS VALID. ABOUND(1,1)=XMIN, C ABOUND(2,1)=XMAX, ABOUND(1,2)=YMIN, ETC.. C 801 CONTINUE C C...GO THROUGH ENTIRE UNIT CELL ON A COARSE GRID. FOR EACH POINT, C...FIGURE OUT WHICH PATTERSON SYMMETRY OPERATION MAPS IT ONTO C ASYMMETRIC UNIT OF PATTERSON. ALSO FIGURE OUT IF ANY POINT C EQUIVALENT TO THIS ONE HAS ANY NON-CRYSTALLOGRAPHIC SYMMETRY C ASSOCIATED WITH IT. C C...TRY TO PUT TEST POINTS IN CENTER OF BOXES NDIV1=ICELL(1)/IDIV(1) NDIV2=ICELL(2)/IDIV(2) NDIV3=ICELL(3)/IDIV(3) INDX=0 NCRMAX=0 C ITST(3)=IDIV(3)/2-IDIV(3) DO 800 I3=1,NDIV3 ITST(3)=ITST(3)+IDIV(3) C ITST(2)=IDIV(2)/2-IDIV(2) DO 800 I2=1,NDIV2 ITST(2)=ITST(2)+IDIV(2) C ITST(1)=IDIV(1)/2-IDIV(1) DO 800 I1=1,NDIV1 ITST(1)=ITST(1)+IDIV(1) C INDX=INDX+1 C C...FIND OPERATION WHICH MAPS ITST(1-3) ONTO ASYMMETRIC UNIT OF PATTERSON C DO 600 J=1,NPROT DO 550 L=1,3 IEQUIV(L)=0 DO 540 LL=1,3 540 IEQUIV(L)=IEQUIV(L)+IPROT(L,LL,J)*ITST(LL) 550 CONTINUE C DO 580 K=1,NCENTR DO 570 L=1,3 570 ITMP(L)=JMOD(IEQUIV(L)+ICENTR(L,K)+ILARG(L),ICELL(L))/2 IF(ITMP(1).GT.NPATXE .OR. ITMP(2).GT.NPATYE .OR. 1 ITMP(3).GT.NPATZE)GO TO 580 C C..THIS IS INSIDE. C GO TO 700 C C..NEXT CENTERING C 580 CONTINUE C C..NEXT OPERATION C 600 CONTINUE C STOP ' INPUT PATTERSON DOES NOT HAVE ASYMMETRIC UNIT OF MAP' C C..RECORD THIS NOW C 700 IOPER(INDX)=(K-1)*NPROT + J-1 C C C..NOW FIND OUT WHICH NON-CRYSTALLOGRAPHIC SYMMETRY OPERATIONS ARE C VALID FOR THIS POINT C II=1 IF(NQNCR.EQ.0)GO TO 800 DO 750 KNCR=1,NNCR C C..IS THIS POINT OR AN EQUIVALENT POINT INSIDE BOUNDARY FOR THIS OPERATION? C DO 740 K=1,NEQUIV DO 724 L=1,3 IEQUIV(L)=0 DO 723 LL=1,3 723 IEQUIV(L)=IEQUIV(L)+IROT(L,LL,K)*ITST(LL) 724 IEQUIV(L)=IEQUIV(L)+ITRANS(L,K) C DO 740 KK=1,NCENTR DO 725 L=1,3 ITMP(L)=JMOD(IEQUIV(L)+ICENTR(L,KK)+ILARG(L),ICELL(L)) 725 IF(ITMP(L).LT.IBOUND(1,L,KNCR) .OR. ITMP(L).GE.IBOUND(2,L,KNCR)) 1 GO TO 740 C C...THIS SET IS WITHIN THE BOUNDARIES SPECIFIED..NOTE THAT UPPER BOUND C IS EXCLUSIVE, LOWER BOUND IS INCLUSIVE. C C...RECORD K,KK, AND KNCR C II=II+1 IF(II.GT.13)STOP'ONLY 12 POSITIONS EQUIV BY NON-CRYST SYMM 1 ETRY TO A GIVEN POINT ALLOWED. CHECK TO MAKE SURE YOU 1 HAVE NOT OVER-DETERMINED ASYMMETRIC UNIT.' C NCRMAX=JMAX0(NCRMAX,II) C C...ONLY ALLOW 12 EQUIVALENT POSITIONS. C INCR(II,INDX)= KNCR-1 + NNCR*( KK-1 + NCENTR* (K-1)) C C...IF THIS POINT IS EQUIVALENT TO ONE INSIDE BOUNDARY, GO ON TO NEXT C POSSIBLE SYMMETRY: DO NOT USE A GIVEN SYMMETRY OPERATOR MORE THAN C ONCE ON A PARTICULAR POINT! C GO TO 750 C C 740 CONTINUE 750 CONTINUE C C..INCR(1,INDX) RECORDS NUMBER OF OPERATIONS TO FOLLOW C INCR(1,INDX)=II-1 C C 800 CONTINUE C NCRMAX=NCRMAX+1 C C..ALL DONE. C C C C...DETERMINE IF COORDINATES ARE FIXED ALONG ALL AXIS OR NOT. C...ANY AXIS WHICH IS NOT FIXED GETS IHOLD(I)=1 C C...METHOD IS SIMPLE: IF NO HARKER VECTORS DEPEND ON COORDINATE K C AND NO NON-CRYSTALLOGRAPHIC SYMMETRY CHANGES COORDINATE K,THEN C AXIS K IS INDETERMINATE C DO 3010 K=1,3 IHOLD(K)=1 DO 3005 IPOS=1,NHARK DO 3005 I=1,3 3005 IF(IHARKR(I,K,IPOS).NE.0 .OR. 1 IHARKR(K,I,IPOS).NE.0 ) IHOLD(K)=0 C IF(NQNCR.EQ.0)GO TO 3010 DO 3009 KNCR=1,NNCR DO 3009 I=1,3 IF(AROT(I,K,KNCR)-FLOAT(IROT(I,K,1)).NE.0. .OR. 1 AROT(K,I,KNCR)-FLOAT(IROT(K,I,1)).NE.0.)IHOLD(K)=0 3009 CONTINUE 3010 CONTINUE C C...WRITE OUT RESULTS C IF(IHOLD(1).EQ.1)WRITE(6,3011) IF(IHOLD(2).EQ.1)WRITE(6,3012) IF(IHOLD(3).EQ.1)WRITE(6,3013) 3011 FORMAT(/,1X,'COORDINATES ALONG X-AXIS ARE DETERMINED', 1 ' ONLY TO WITHIN A CONSTANT.') 3012 FORMAT(/,1X,'COORDINATES ALONG Y-AXIS ARE DETERMINED', 1 ' ONLY TO WITHIN A CONSTANT.') 3013 FORMAT(/,1X,'COORDINATES ALONG Z-AXIS ARE DETERMINED', 1 ' ONLY TO WITHIN A CONSTANT.') C...NOW DETERMINE POSSIBLE CENTERINGS OF SOLUTIONS TO A SET OF HARKER C VECTORS. E.G., IN SPACE GROUP P222, (X,Y,Z),(1/2-X,Y,Z),(X,1/2-Y,Z),... C ARE ALL SOLUTIONS RELATED BY CENTERING OR INVERSION. C NTOL4=0 NTOL2=0 C NORIG=1 DO 3100 L=1,3 3100 IORIG(L,1)=0 C C....GET ALL OTHER CENTERINGS WHICH ARE NOT EQUIVALENT TO (0,0,0) BY SPACE C GROUP SYMMETRY YET WHICH YIELD SAME PATTERSON HARKER VECTORS C IF(NHARK.EQ.0)GO TO 3300 C C..GET A POINT WHICH IS IN A GENERAL POSITION C DO 3155 I=1,ICELL(1)/2 DO 3155 J=1,ICELL(2)/2 DO 3155 K=1,ICELL(3)/2 CALL SPECR(I,J,K,ISPEC) 3155 IF(ISPEC.EQ.1)GO TO 3157 WRITE(6,3156) 3156 FORMAT(1X,'NOTE: WAS UNABLE TO FIND A POINT IN GENERAL POSITION.') IGEN(1)=1 IGEN(2)=1 IGEN(3)=1 GO TO 3160 3157 IGEN(1)=I IGEN(2)=J IGEN(3)=K WRITE(6,3158)(FLOAT(IGEN(L))/FLOAT(ICELL(L)),L=1,3) 3158 FORMAT(/,1X,'A POINT IN A GENERAL POSITION IS: ', 1 '(',F5.3,',',F5.3,',',F5.3,')',/) C DO 3200 I1=0,1-IHOLD(1) ITMP(1)=I1*ICELL(1)/2 DO 3200 I2=0,1-IHOLD(2) ITMP(2)=I2*ICELL(2)/2 DO 3200 I3=0,1-IHOLD(3) ITMP(3)=I3*ICELL(3)/2 C C...ITMP IS A POSSIBLE CENTERING. NOW SEE IF (X,Y,Z)+(ITMP(1),ITMP(2),ITMP(3) C C (1) HAS SAME HARKER VECTORS AS (0,0,0)+(X,Y,Z) C (2) IS NOT EQUIVALENT TO A CENTERING ALREADY FOUND C DO 3120 K=1,NHARK C C....GET HARKER VECTORS FOR THIS CENTERING RELATIVE TO THOSE FOR (X,Y,Z) C DO 3115 L=1,3 INDX=0 DO 3114 LL=1,3 3114 INDX=INDX+IHARKR(L,LL,K)*ITMP(LL) 3115 ITST(L)=INDX C C...IS THIS OFFSET EQUAL TO 0? C CALL SAMEP(ITST(1),ITST(2),ITST(3),0,0,0,ISAME) 3120 IF(ISAME.EQ.0)GO TO 3200 C C...HERE THE OFFSET IN HARKER VECTORS ARE ALL EQUIVALENT TO (0,0,0) C NOW MAKE SURE THIS ISN'T THE SAME AS A PREVIOUS SOLUTION. C C...THE FOLLOWING ASSUMES THAT POINT IS IN A GENERAL POSITION DO 3150 I=1,NORIG CALL SAMER(IORIG(1,I)+IGEN(1),IORIG(2,I)+IGEN(2), 1 IORIG(3,I)+IGEN(3), 1 ITMP(1)+IGEN(1),ITMP(2)+IGEN(2),ITMP(3)+IGEN(3), 1 ISAME) 3150 IF(ISAME.EQ.1)GO TO 3200 C C...THIS IS NEW. STORE IT. C NORIG=NORIG+1 DO 3160 L=1,3 3160 IORIG(L,NORIG)=ITMP(L) C 3200 CONTINUE C C C...ALL DONE. WRITE OUT POSSIBLE CENTERINGS. C 3300 WRITE(6,3250)(I,(FLOAT(IORIG(L,I))/FLOAT(ICELL(L)) 1 ,L=1,3),I=1,NORIG) 3250 FORMAT(/,1X,'THE FOLLOWING POINTS, UNRELATED BY', 1 ' SPACE GROUP SYMMETRY OR INVERSION,' 1 ,/,1X,'WILL ALL HAVE THE SAME', 1 ' HARKER VECTORS:',//, 1 8(1X,I5,5X,'(X+',F3.1,', Y+',F3.1,', Z+',F3.1,') ',/) ) C C..TWO DUMMY CALLS C CALL SPECR(0,0,0,ISPEC) DUMMY=CUT(1,1,0.5) RETURN END SUBROUTINE MINIM(IFLAG,RHO) C C GENERATES ALL POSITIONS IN UNIT CELL EQUIVALENT TO THE C NMIN POSITIONS GIVEN IN ARRAYS IMIN,JMIN AND KMIN. C C IF NON-CRYSTALLOGRAPHIC SYMMETRY IS INCLUDED, ALL POSITIONS C EQUIVALENT BY THIS SYMMETRY ARE ALSO GENERATED. C C IF IFLAG>0, MINIMUM VALUE OF PATTERSON AT(SELF AND) CROSS C VECTORS FOR ALL THESE POSITIONS IS RETURNED IN RHO C C IF IFLAG =3 MINIMUM VALUE OF PATTERSON AT CROSS VECTORS C BETWEEN THESE POSITIONS AND THE NSOLN STARTING SOLUTIONS IN ARRAY C ISOLN WILL ALSO BE CALCULATED AND INCLUDED IN OVERALL MINIMUM (RHO) C C....NOTE: THE STARTING SET OF NMIN POSITIONS MUST BE PLACED IN ARRAYS C IMIN,JMIN,KMIN STARTING AT POSITION 1, THEN POSITION NEQUIV+1, C THEN POSITION NEQUIV*2 +1, ETC. C C.......ROUTINE RETURNS ALL EQUIVALENT POSITIONS IN SETS OF (NEQUIV) C IN ARRAYS IMIN,JMIN,KMIN. CENTERED POSITIONS ARE NOT CONSIDERED. C C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C....LOCAL VARIABLES C DIMENSION IR(216),IT(72) EQUIVALENCE (IR(1),IROT(1)),(IT(1),ITRANS(1)), 1 (IC1,ICELL(1)),(IC2,ICELL(2)),(IC3,ICELL(3)), 1 (IL1,ILARG(1)),(IL2,ILARG(2)),(IL3,ILARG(3)), 1 (IDIV1,IDIV(1)),(IDIV2,IDIV(2)),(IDIV3,IDIV(3)) C C C C********* WARNING: NEVER LET THIS ROUTINE WRITE INTO IMIN(1),JMIN(1),OR C KMIN(1). THEY ARE EQUIVALENCED TO LOOP VARIABLES C ELSEWHERE. C C C RHO=1.E+30 IF(NMIN.LT.1)RETURN C C...EXPAND THE NMIN POSITIONS CURRENTLY IN ARRAYS IMIN,JMIN,KMIN INTO C ALL NON-CRYSTALLOGRAPHICALLY RELATED POINTS, IF APPLICABLE. C IF(NQNCR.EQ.0)GO TO 49 C C...CALCULATE INDEX OF BOX FOR NON-CRYST SYMMETRY C NNMIN=NMIN NNEXT=1+NMIN*NEQUIV IF(NNEXT.GT.200)STOP 'OUT OF BUFFER IN ROUTINE 1 "MINIM" ' NCUR=1 DO 48 N=1,NNMIN I1=JMOD(IMIN(NCUR)+IL1,IC1) J1=JMOD(JMIN(NCUR)+IL2,IC2) K1=JMOD(KMIN(NCUR)+IL3,IC3) C INDX=1+(I1/IDIV1) + NDIV1*(J1/IDIV2+NDIV2*(K1/IDIV3)) C C..CHECK TO SEE HOW MANY "EQUIV" POSITIONS THERE ARE NNON=INCR(1,INDX) IF(NNON.EQ.0)GO TO 48 C C...EXPAND THIS POINT ONTO NON-CRYST EQUIVALENT C DO 35 II=1,NNON NMIN=NMIN+1 C C..GET SYMMETRY OPERATION TO MAP THIS POINT ONTO ASYMMETRIC UNIT, C...ALSO NON-CRYSTALLOGRAPHIC SYMMETRY OPERATION ONCE WE ARE THERE. C INCR1=INCR(II+1,INDX) C K=INCR1/(NNCR*NCENTR) INCR1=INCR1-K*(NNCR*NCENTR) KK=INCR1/NNCR KNCR=INCR1-KK*NNCR C KKST=9*K C K=K+1 KK=KK+1 KNCR=KNCR+1 C C...NOW K= INDEX OF ROTATION MATRIX, KK INDEX OF CENTERING MATRIX TO BRING C THIS POINT INTO ASYMMETRIC UNIT (OR REGION WHERE NON-CRYST SYMMETRY C APPLIES). KNCR IS INDEX OF NON-CRYST SYMMETRY. C C...MAP THIS POINT ONTO PROPER REGION. C EQ1=FLOAT(JMOD(ITRANS(1,K)+ICENTR(1,KK)+IR(KKST+1)*I1+ 1 IR(KKST+4)*J1+IR(KKST+7)*K1+IL1,IC1) ) EQ2=FLOAT(JMOD(ITRANS(2,K)+ICENTR(2,KK)+IR(KKST+2)*I1+ 1 IR(KKST+5)*J1+IR(KKST+8)*K1+IL2,IC2) ) EQ3=FLOAT(JMOD(ITRANS(3,K)+ICENTR(3,KK)+IR(KKST+3)*I1+ 1 IR(KKST+6)*J1+IR(KKST+9)*K1+IL3,IC3) ) C C..NOW MAP THIS POSITION ONTO NON-CRYSTALLOGRAPHIC EQUIVALENT. C 31 AAA=ATRAN(1,KNCR)+AROT(1,1,KNCR)*EQ1+ 1 AROT(1,2,KNCR)*EQ2+AROT(1,3,KNCR)*EQ3 IMIN(NNEXT)=INT(AAA+SIGN(0.5,AAA)) AAA=ATRAN(2,KNCR)+AROT(2,1,KNCR)*EQ1+ 1 AROT(2,2,KNCR)*EQ2+AROT(2,3,KNCR)*EQ3 JMIN(NNEXT)=INT(AAA+SIGN(0.5,AAA)) AAA=ATRAN(3,KNCR)+AROT(3,1,KNCR)*EQ1+ 1 AROT(3,2,KNCR)*EQ2+AROT(3,3,KNCR)*EQ3 KMIN(NNEXT)=INT(AAA+SIGN(0.5,AAA)) C NNEXT=NNEXT+NEQUIV 35 IF(NNEXT.GT.200)STOP'OUT OF BUFFER IN ROUTINE 1 "MINIM" ' 48 NCUR=NCUR+NEQUIV C C...ALL DONE WITH APPLICATION OF NON-CRYSTALLOGRAPHIC SYMMETRY. C C C...MMIN IS TOTAL NUMBER OF POSITIONS IN UNIT CELL WHICH ARE EQUIVALENT TO C THE NMIN UNIQUE ONES WHICH ARE INPUT C 49 MMIN=0 NCUR=1 DO 100 I=1,NMIN MMIN=MMIN+1 II=IMIN(NCUR) JJ=JMIN(NCUR) KK=KMIN(NCUR) C KST=3 KKST=9 DO 50 K=2,NEQUIV MMIN=MMIN+1 IMIN(MMIN)=IT(KST+1)+IR(KKST+1)*II+IR(KKST+4)*JJ+IR(KKST+7)*KK JMIN(MMIN)=IT(KST+2)+IR(KKST+2)*II+IR(KKST+5)*JJ+IR(KKST+8)*KK KMIN(MMIN)=IT(KST+3)+IR(KKST+3)*II+IR(KKST+6)*JJ+IR(KKST+9)*KK KST=KST+3 50 KKST=KKST+9 C 100 NCUR=NCUR+NEQUIV C C...NOW WE HAVE GENERATED ALL POSITIONS EQUIVALENT TO STARTING NMIN POINTS C BY SPACE GROUP SYMMETRY, IGNORING CENTERING. C IF(IFLAG.LT.0)RETURN C C C...NOW GET MINIMUM OF PATTERSON FUNCTION AT ALL CROSS VECTORS FROM THESE C POINTS C DO 400 I=1,MMIN,NEQUIV II=IMIN(I) JJ=JMIN(I) KK=KMIN(I) C C...NOTE THAT ONLY 1 OUT OF EVERY NEQUIV POSITIONS NEEDS TO BE CONSIDERED FOR C CROSS VECTORS, ALL OTHERS WOULD JUST DUPLICATE THE RESULTS. C DO 400 J=1,MMIN CALL PATT(II-IMIN(J),JJ-JMIN(J),KK-KMIN(J),A) RHO=AMIN1(RHO,A) IF(RHO.GT.CUTOFF)GO TO 400 RHO=-1.E+30 RETURN 400 CONTINUE C C IF(IFLAG.NE.3)RETURN C C..GET MINIMUM VALUE OF CROSS VECTORS BETWEEN THESE POSITIONS AND STARTING C SOLUTIONS IN ARRAY ISOLN C DO 500 I=1,NSOLN II=ISOLN(1,I) JJ=ISOLN(2,I) KK=ISOLN(3,I) C DO 500 J=1,MMIN CALL PATT(II-IMIN(J),JJ-JMIN(J),KK-KMIN(J),A) RHO=AMIN1(RHO,A) IF(RHO.GT.CUTOFF)GO TO 500 RHO=-1.E+30 RETURN 500 CONTINUE RETURN C END SUBROUTINE ISIGNF(NSRCH,NSTART,IFLAG,APROB,SAMIN) C C FUNCTION: DETERMINES WHETHER PEAK IX,IY,IZ IS LIKELY TO C HAVE OCCURED BY CHANCE. C C DETERMINES MINIMUM VALUE OF ASAVE=RHO/(SIGMA*ISYMM) OVER: C C (1) SELF VECTORS FOR (IX,IY,IZ) C (2) IF IFLAG IS NOT 0, SELF VECTORS FOR ISOLN(1-3,1) C (3) ALL CROSS VECTORS BETWEEN (IX,IY,IZ) AND ISOLN(1-3,1-NSOLN) C C ALSO DETERMINES TOTAL NUMBER OF UNIQUE PLACES IN PATTERSON MAP C LOOKED AT BY THESE POINTS WHICH HAVE NOT ALREADY BEEN USED C BY AN EARLIER SOLUTION = NUNIK C C...... IFLAG IS NUMBER OF CALLING ROUTINE : 1=SINGLE, 2=DOUBLE, 3=TRIPLE C C APROB IS PROBABILITY THAT (NDIF-NSTART) PEAKS WOULD NOT BE C FOUND ALL > OBSERVED MINIMUM RHO/(SIGMA*ISYMM) IN NSRCH TRIES IS C GREATER THAN SIGNIF C C.. ALSO DETERMINES SAMIN, THE MINIMUM VALUE OF RHO(X)/# OF C VECTORS FALLING ON X C. C..ASAVE= MINIMUM VALUE OF RHO(X)/SYMMETRY # OF X. C C COMMON BLOCKS FOR PROGRAM "HASSP" C C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C DIMENSION ITST(3),JTST(3),KTST(3,24),LTST(3,240) C C IF(IFLAG.GE.0)GO TO 1 C C...INITIALIZE THIS ROUTINE AND STORAGE OF PEAKS IN "NEW" : FORGET ABOUT C ALL OLD SOLUTIONS WHICH WERE USED BEFORE C NSSAVE=0 NTOT=0 CALL NEW(0,0,0,ASAVE,NDIF,SAMIN,NUNIK,-2) RETURN C C C...NORMAL CALL. FIRST MAKE SURE THAT THIS TEST SOLUTION C HAS POSITIVE SELF AND CROSS VECTORS (SO THAT USING THIS C ROUTINE IS WORTH THE TIME). C 1 CALL MINIM(IFLAG,RHO) IF(RHO.GT.CUTOFF)GO TO 2 APROB=0. ASAVE=-1.E+30 SAMIN=-1.E+30 RETURN C C C...THIS SOLUTION HAS POTENTIAL, AT LEAST. FIND OUT PROBABILITY OF C IT NOT OCCURING BY CHANCE C C 2 ASAVE=1.E+30 SAMIN=1.E+30 NDIF=0 NUNIK=0 C C...FOR THIS ROUTINE, PEAKS MUST BE WITHIN 2 GRID UNITS TO BE CONSIDERED C OVERLAPPING. THIS INCLUDES PATTERSON PEAKS. THEREFORE SET TOLERANCES C ACCORDINGLY. C NTOL4=2 C IF(IFLAG.NE.3)GO TO 6 C C...HERE THIS IS CALL AFTER TRIPLE. C C...FIRST BRING BACK CROSS-VECTORS FROM SOLUTION WHICH WAS KNOWN WHEN THIS C ROUTINE WAS LAST CALLED.(CURRENT SOLUTION WILL BE SAME OR HAVE ADDED C SITES.) C CALL NEW(0,0,0,ASAVE,NDIF,SAMIN,NUNIK,-1) C C..NSSAVE IS NUMBER OF SOLUTIONS WHEN ROUTINE WAS LAST CALLED. IF IT IS C SAME AS NSOLN, THEN CALL TO NEW (ABOVE) PUT ALL CORRECT CROSS VECTORS C IN PLACE, NO NEED TO RECALCULATE THEM. ALSO ARRAY LTST ALREADY HAS C ALL POSITIONS EQUIVALENT TO THESE SOLUTIONS. C NTSAVE=NTOT IF(NSSAVE.EQ.NSOLN)GO TO 45 DO 4 I=NSSAVE+1,NSOLN DO 4 K=1,NEQUIV C NTOT=NTOT+1 DO 4 L=1,3 INDX=0 DO 3 LL=1,3 3 INDX=INDX+IROT(L,LL,K)*ISOLN(LL,I) 4 LTST(L,NTOT)=INDX+ITRANS(L,K) C C...NOW ARRAY LTST HAS ALL EQUIVALENT POSITIONS FOR ALL SOLUTIONS. C...CALL ROUTINE NEW WITH ALL SELF AND CROSS VECTORS FROM ALL THESE C...EQUIVALENT POSITIONS. C C...IF THIS IS FIRST CALL (NSSAVE=0), PUT IN ORIGIN. C IF(NSSAVE.EQ.0)CALL NEW(0,0,0,ASAVE,NDIF,SAMIN,NUNIK,0) C DO 5 I=1,NTOT-1 DO 5 J=JMAX0(I+1,NTSAVE+1),NTOT 5 CALL NEW(LTST(1,I)-LTST(1,J),LTST(2,I)-LTST(2,J), 1 LTST(3,I)-LTST(3,J),ASAVE,NDIF,SAMIN,NUNIK,0) C C...NOW ARRAY IXYZ IN ROUTINE "NEW" HAS ALL SELF AND CROSS VECTORS FOR C...THIS SOLUTION. NOW INITIALIZE THE ROUTINE "NEW" SO THAT C THESE OLD PEAKS ARE NOT COUNTED C NSSAVE=NSOLN C 45 CALL NEW(0,0,0,ASAVE,NDIF,SAMIN,NUNIK,1) C C C C...NOW CALL ROUTINE "NEW" WITH ALL CROSS VECTORS FOR ALL POSITIONS C C..NOTE THAT CALL TO ROUTINE "MINIM" ABOVE GENERATED ALL POSITIONS C EQUIVALENT TO THE TEST SOLUTION BY CRYST AND NON-CRYST SYMMETRY C IN ARRAYS IMIN,JMIN,KMIN, FOR A TOTAL OF MMIN POINTS. C C...ALWAYS CALL WITH ORIGIN C 6 CALL NEW(0,0,0,ASAVE,NDIF,SAMIN,NUNIK,0) DO 100 I=1,MMIN-1 II=IMIN(I) JJ=JMIN(I) KK=KMIN(I) DO 100 J=I+1,MMIN 100 CALL NEW(II-IMIN(J),JJ-JMIN(J),KK-KMIN(J),ASAVE,NDIF,SAMIN,NUNIK,0) C IF(IFLAG.NE.3)GO TO 500 C C...GET ALL CROSS VECTORS BETWEEN ALL POSITIONS AND STARTING SOLUTIONS TOO. C DO 200 I=1,NTOT II=LTST(1,I) JJ=LTST(2,I) KK=LTST(3,I) DO 200 J=1,MMIN 200 CALL NEW(IMIN(J)-II,JMIN(J)-JJ,KMIN(J)-KK,ASAVE,NDIF,SAMIN,NUNIK,0) C C 500 CONTINUE APROB=PROB(NUNIK-NSTART,NSRCH,ASAVE/AMAX1(1.E-10,SIGMA) ) C C C..NUNIK IS TOTAL # OF UNIQUE PEAKS LOOKED AT BY THIS ROUTINE, NSTART C...IS NUMBER WHICH HAD TO BE THERE (EXCEPT ORIGIN), -1 IS FOR ORIGIN, C...WHICH IS ALWAYS THERE. C C...PUT TOLERANCES BACK TO NORMAL C NTOL4=4 C RETURN END SUBROUTINE NEW(IX,IY,IZ,ASAVE,NDIF,SAMIN,NUNIK,INIT) C C THIS SUBPROGRAM IS CALLED ONLY BY ROUTINE ISIGNF C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C..LOCAL VARIABLES C DIMENSION ASQRT(25) DATA ASQRT /1.00,1.41,1.73,2.00,2.24,2.45,2.65,2.83,3.00,3.16, 1 3.32,3.46,3.61,3.74,3.87,4.00,4.12,4.24,4.36,4.47, 1 4.58,4.69,4.80,4.90,5.00/ C DIMENSION IXYZ(3,400),NREP(400),ASA(400),INEW(400),ITST(3) DIMENSION IXSA(3,400),NRSA(400) C IF(INIT)20,10,2 C C...IF INIT IS -2, FORGET ALL ABOUT OLD SOLUTIONS WE HAVE STORED. START AGAIN C 20 IF(INIT.NE.-2)GO TO 18 NDIFSA=0 NDIF=0 RETURN C C C...NORMAL INITIALIZATION: PUT OLD SOLUTION CROSS-VECTORS BACK INTO C STORAGE ARRAY C 18 IF(NDIFSA.EQ.0)RETURN DO 25 I=1,NDIFSA NREP(I)=NRSA(I) DO 25 L=1,3 25 IXYZ(L,I)=IXSA(L,I) NDIF=NDIFSA RETURN C C C...SECOND INITIALIZATION: AFTER ALL CROSS-VECTORS FROM KNOWN SOLUTIONS C ARE STORED. SET NUNIK=0, ETC... THE REASON WE MUST SAVE ALL THESE OLD C CROSS-VECTORS IS SO THAT PEAKS WHICH HAVE LOTS OF CROSS-VECTORS FALLING C ON THEM ARE COUNTED AS LOWER ONES THAN PEAKS WHICH HAVE ONLY ONE. C 2 DO 1 I=1,NDIF INEW(I)=0 1 ASA(I)=1.E+30 SAMIN=1.E+30 ASAVE=1.E+30 NUNIK=0 IF(NDIF.LE.NDIFSA)RETURN C C...HERE IF THE CURRENT SET OF VECTORS FROM KNOWN SOLUTIONS IS GREATER C THAN THE SET WHEN LAST CALLED. SAVE THE NEW ONES C DO 14 I=1,NDIF NRSA(I)=NREP(I) DO 14 L=1,3 14 IXSA(L,I)=IXYZ(L,I) NDIFSA=NDIF RETURN C C C....NORMAL CALL IS HERE. CHECK VECTOR AND ITS INVERSE C 10 ITST(1)=IX ITST(2)=IY ITST(3)=IZ C DO 2000 INV=0,1 IF(INV.EQ.0)GO TO 12 DO 11 L=1,3 11 ITST(L)=-ITST(L) J=JLAST C C...DON'T NEED TO RECALCULATE WHICH POINT THIS IS EQUIVALENT TO C BY PATTERSON SYMMETRY: ITS THE SAME AS ITS INVERSE. C GO TO 183 C C C..NOW SEE IF THIS NEW POINT IS UNIQUE (WITH PATTERSON SYMMETRY) C..IF IT IS EQUIVALENT TO AN OLD POINT BY PATTERSON SYMMETRY, IS IT C..THE SAME POINT? IF SO, INCREMENT NUMBER OF REPETITIONS OF THIS C POINT AND MINIMUM VALUE AT THIS POINT. IF NOT, FORGET IT. C..IF IT IS UNIQUE, STORE IT AND INCREMENT NDIF. THEN INCREMENT C NUMBER OF REPETIONS OF THIS POINT AND MINIMUM VALUE OF THIS C POINT. 12 IF(NDIF.EQ.0)GO TO 190 DO 190 J=1,NDIF CALL SAMEP(IX,IY,IZ,IXYZ(1,J),IXYZ(2,J),IXYZ(3,J),ISAME) IF(ISAME.EQ.0)GO TO 190 C C..THIS POINT IS EQUIVALENT BY PATTERSON SYMMETRY TO ONE ALREADY HERE C..NOW IS THIS POINT THE SAME? C JLAST=J C 183 DO 185 K=1,NCENTR DO 184 L=1,3 INDX=JMOD(ITST(L)+ICENTR(L,K)-IXYZ(L,J) +ILARG(L),ICELL(L)) IF(INDX.GT.NTOL4)INDX=ICELL(L)-INDX 184 IF(INDX.GT.NTOL4)GO TO 185 C.. C...THIS POINT IS THE SAME AS POINT J. INCREMENT REPETIONS, ETC. C GO TO 200 C 185 CONTINUE C C...THIS IS NOT THE SAME POINT BUT IT IS EQUIVALENT BY PATTERSON SYMMETRY C SO FORGET IT C GO TO 2000 C 190 CONTINUE C C..THIS POINT IS NOT THE SAME (BY PATTERSON SYMMETRY) AS ANY OTHER C POINT CURRENTLY IN THE LIST. PUT IT IN NOW. C IF(NDIF.LT.400)GO TO 195 IF(IFIRST.NE.0)GO TO 194 IFIRST=1 WRITE(6,199) 199 FORMAT(1X,'**** WARNING -- RAN OUT OF BUFFER IN "NEW" ***') 194 GO TO 2000 195 NDIF=NDIF+1 DO 198 L=1,3 198 IXYZ(L,NDIF)=ITST(L) NREP(NDIF)=0 ASA(NDIF)=1.E+30 INEW(NDIF)=0 J=NDIF JLAST=J C 200 CONTINUE C C...J IS NOW INDEX OF THIS POINT. IF IT IS NDIF+1, THEN THIS IS A NEW C POINT, OTHERWISE ITS CLOSE TO AN OLD POINT (J) C C...RECORD WHETHER THIS IS THE FIRST TIME THIS POINT HAS COME UP C SINCE INITIALIZATION OF THIS ROUTINE. NUNIK RECORDS # OF TIMES C A UNIQUE POINT HAS COME UP. NOTE THAT NREP(J) INCLUDES REPETITIONS C FROM ALL EARLIER SOLUTIONS. NUNIK DOES NOT. C IF(INEW(J).EQ.1)GO TO 210 INEW(J)=1 NUNIK=NUNIK+1 210 CONTINUE C C..FIND VALUE OF PATTERSON FUNCTION HERE, GET SYMMETRY OF THIS POINT. C CALL PATT(IX,IY,IZ,A) CALL SPECP(IX,IY,IZ,ISPEC) IF(ISPEC.GT.25)ISPEC=25 ASAVE=AMIN1(ASAVE,A/ASQRT(ISPEC)) C C...ASAVE IS MINIMUM RATIO OF PEAK HEIGHT/NOISE LEVEL * SIGMA C C...SAMIN IS MINIMUM VALUE OF PEAK HEIGHT/# OF CROSS VECTORS FALLING C ON THIS POINT. C NREP(J)=NREP(J)+1 ASA(J)=AMIN1(ASA(J),A) SAMIN=AMIN1(SAMIN,ASA(J)/FLOAT(NREP(J))) 2000 CONTINUE C RETURN END SUBROUTINE PATPK C C...FUNCTION: C C SEARCH FOR ISOLATED PEAKS IN INPUT PATTERSON MAP WHICH ARE AT LEAST C EQUAL IN HEIGHT TO RMS FLUCTUATION IN MAP. C RESULTS ARE PRINTED AND SAVED IN ARRAY ICROSS AFTER SEPARATION INTO C GENERAL AND SPECIAL POSITIONS (SUBROUTINE SORT) C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C C...INITIALIZE STORAGE ROUTINE C CALL SAVEP(-1) C C...SELECT VALUE OF PATTERSON FUNCTION BELOW WHICH ALL VALUES WILL BE SET C TO ZERO C CUTOFF=-1.E+30 NPEAK=0 NPMAX=50 C C.FOR LARGE UNIT CELLS, SAVE 100 PEAKS C IF(NPATZE.GT.50)NPMAX=100 C C...FIRST GET RMS VALUE IN MAP C SUMN=0. SUMR=0. SUMRR=0. DO 1 K=1,NX1*NY1*NZ1 F0=PATTER(K) SUMN=SUMN+1. SUMR=SUMR+F0 SUMRR=SUMRR+F0*F0 1 CONTINUE AMIN=SQRT (( SUMRR - SUMR**2/SUMN )/SUMN) C WRITE(6,2)NX1*NY1*NZ1,AMIN 2 FORMAT(/,1X,'INPUT PATTERSON MAP HAS ',I8,' ELEMENTS ', 1 ' AND AN RMS VALUE OF ',G15.5,', SCALED TO 1000.0') C C...UNCERTAINTY IN MAP = RMS VALUE IN MAP C SIGMA=1000. C C...SCALE RMS VALUE IN MAP TO 1000.0 C RHO=1000./AMAX1(1.E-10,AMIN) DO 3 K=1,NX1*NY1*NZ1 3 PATTER(K)=PATTER(K)*RHO AMIN=500. C C...NOW GET AN ESTIMATE OF NUMBER OF DEGREES OF FREEDOM IN MAP C IF ALL REFLECTIONS EQUAL INTENSITY, NFREE=NREFLN C WE TAKE NFREE=#OF PEAKS+#OF VALLEYS = 2*#OF PEAKS. C NFREE=0 C C...NOW LOOK FOR PEAKS > 1/2 RMS VALUE IN MAP C C...NOTE THAT SUBROUTINE PATT(I,J,K,RHO) RETURNS VALUE OF PATTERSON C FUNCTION AT GRID POINT (I,J,K) WHERE I,J,K ARE ON A GRID EXACTLY C TWICE AS FINE AS THE INPUT PATTERSON FUNCTION. THEREFORE VALUES C OF PATTERSON FUNCTION ARE ONLY AVAILABLE FOR EVEN VALUES OF I,J,K. C DO 1000 K=0,NPATZE*2,2 DO 1000 J=0,NPATYE*2,2 DO 1000 I=0,NPATXE*2,2 CALL PATT(I,J,K,F0) C C...IS IT GREATER THAN ALL ITS NEIGHBORS? C DO 50 II=-2,2,2 DO 50 JJ=-2,2,2 DO 50 KK=-2,2,2 IF(II.EQ.0 .AND. JJ.EQ.0 .AND. KK.EQ.0)GO TO 50 CALL PATT(I+II,J+JJ,K+KK,RHO) IF(RHO.GT.F0)GO TO 1000 50 CONTINUE C C...THIS IS A PEAK C C NFREE=NFREE+2 C IF(F0.LE.AMIN)GO TO 1000 C C...IT'S A PEAK GREATER THAN SIGMA/2. NOW IS IT AN ISOLATED PEAK? C DO 100 IBOX=2,NBOX*2,2 DO 75 II=-IBOX,IBOX,2 DO 75 JJ=-IBOX,IBOX,2 DO 75 KK=-IBOX,IBOX,2 C IF(IABS(II).NE.IBOX .AND. IABS(JJ).NE.IBOX .AND. IABS(KK).NE.IBOX) 1 GO TO 75 C C...THIS IS A SIDE OF THE BOX. ALL VALUES ON SIDE MUST BE < 1/DISCRM * F0 C CALL PATT(I+II,J+JJ,K+KK,RHO) IF(RHO*DISCRM.GT.F0)GO TO 100 75 CONTINUE C C...THIS IS ISOLATED, SAVE IT C CALL SAVEP(0,I,J,K,F0,0.,0) C C..SAVEP NORMALLY INCREASES CUTOFF WHEN PEAK LIST IS FULL DON'T ALLOW C IT TO DO THIS. C CUTOFF=-1.E+30 GO TO 1000 C C...TRY ANOTHER IBOX C 100 CONTINUE C C C...NEXT POINT: C 1000 CONTINUE C C C...WRITE OUT NUMBER OF DEGREES OF FREEDOM C WRITE(6,1002)NFREE 1002 FORMAT(1X,'NUMBER OF DEGREES OF FREEDOM IN PATTERSON MAP WHICH', 1 ' IS ABOUT',/, 1 ' EQUAL TO THE NUMBER OF PEAKS+VALLEYS IN MAP: ',I10) C C...CALCULATE A FACTOR ALPHA SUCH THAT: C C... (ICELL(1)*ALPHA)*(ICELL(2)*ALPHA)*(ICELL(3)*ALPHA)=NFREE C C...THEN THE NUMBER OF DEGREES OF FREEDOM ON A PLANE, SAY X-Y IS: C C N= (ICELL(1)*ALPHA)*(ICELL(2)*ALPHA) C ALPHA=(FLOAT(NFREE)/(FLOAT(ICELL(1))*FLOAT(ICELL(2))* 1 FLOAT(ICELL(3))) )**(1./3.) C C C...REWRITE PEAKS INTO ORDER C CALL SAVEP(1) C IF(NPEAK.GT.0)GO TO 1100 C 1003 WRITE(6,1001) 1001 FORMAT(//,1X,'NO ISOLATED PEAKS ABOVE 1/2 RMS VALUE', 1 ' IN MAP FOUND IN PATTERSON.', 1 /,' TRY A SMALLER VALUE OF" DISCRM"') IF(ITYPE.GT.0)NCROSS=0 RETURN C C 1100 CONTINUE C C...ELIMINATE ALL DUPLICATIONS AND ORIGINS NOW. C NP=0 DO 1500 I=1,NPEAK C C...ELIMINATE IT IF IT IS ORIGIN OR CENTERED ORIGIN C C...SUBROUTINE SAMEP RETURNS ISAME=1 IF THE TWO POINTS ARE RELATED BY C PATTERSON SYMMETRY (WITHIN TOLERANCE NTOL4) C CALL SAMEP(IPXYZ(1,I),IPXYZ(2,I),IPXYZ(3,I),0,0,0,ISAME) IF(ISAME.EQ.1)GO TO 1500 C C...NOW ELIMINATE ALL PEAKS EQUIVALENT TO PEAK CURRENTLY IN LIST C IF(NP.EQ.0)GO TO 1400 DO 1300 J=1,NP CALL SAMEP(IPXYZ(1,I),IPXYZ(2,I),IPXYZ(3,I), 1 IPXYZ(1,J),IPXYZ(2,J),IPXYZ(3,J),ISAME) C 1300 IF(ISAME.EQ.1)GO TO 1500 C C...THIS IS A NEW PEAK (NOT EQUIVALENT BY PATTERSON SYMMETRY) C 1400 NP=NP+1 DO 1450 L=1,3 1450 IPXYZ(L,NP)=IPXYZ(L,I) PEAK(NP) =PEAK(I) C 1500 CONTINUE NPEAK=NP C IF(NPEAK.EQ.0)GO TO 1003 C C...ALL DONE, NOW SORT PEAKS ON BASIS OF SPECIAL POSITIONS OR NOT. C AND PUT THEM IN ARRAYS IPXYZ1 (GENERAL) OR IPXYZ2 (SPECIAL). C...IF NOSPEC=1, PUT THEM ALL IN IPXYZ1 C C CALL SORT(0,0) C C...WRITE OUT RESULTS C IF(NPEAK1.EQ.0)GO TO 2500 WRITE(6,2001) 2001 FORMAT(//,' LIST OF ISOLATED PATTERSON PEAKS:', 1 ' GENERAL POSITIONS.',//, 1 3X,'PEAK',9X,'X',9X,'Y',9X,'Z',9X,'HEIGHT',/) C WRITE(6,2002)(I,(FLOAT(IPXYZ1(L,I))/FLOAT(ICELL(L)),L=1,3), 1 PEAK1(I),I=1,NPEAK1) 2002 FORMAT(I6,4X,3F10.3,G15.5) C 2500 IF(NPEAK2.EQ.0)GO TO 3000 WRITE(6,2501) 2501 FORMAT(//,' LIST OF ISOLATED PATTERSON PEAKS:', 1 ' SPECIAL POSITIONS.',//, 1 3X,'PEAK',9X,'X',9X,'Y',9X,'Z',9X,'HEIGHT',4X,'SYMM #',/) C WRITE(6,2502)(I,(FLOAT(IPXYZ2(L,I))/FLOAT(ICELL(L)),L=1,3), 1 PEAK2(I),ISYMM(I),I=1,NPEAK2) 2502 FORMAT(I6,4X,3F10.3,G15.5,I5) C 3000 CONTINUE C C C..SAVE ALL PEAKS BY PUTTING THEM IN ARRAY ICROSS AND PCROSS C IF(ITYPE.LT.0)GO TO 3302 NCROSS=0 IF(NPEAK1.EQ.0)GO TO 3150 DO 3100 I=1,NPEAK1 NCROSS=NCROSS+1 PCROSS(NCROSS)=PEAK1(I) DO 3100 L=1,3 3100 ICROSS(L,NCROSS)=IPXYZ1(L,I) C C 3150 IF(NPEAK2.EQ.0)GO TO 3300 DO 3200 I=1,NPEAK2 NCROSS=NCROSS+1 PCROSS(NCROSS)=PEAK2(I) DO 3200 L=1,3 3200 ICROSS(L,NCROSS)=IPXYZ2(L,I) 3300 NCROSS=JMIN0(NCROSS,ICRMAX) 3302 WRITE(6,3301) 3301 FORMAT('1') RETURN END SUBROUTINE SINGLE C C..FUNCTION: C C...SEARCH OVER SUPPLIED GRID FOR 1-ATOM SOLUTIONS TO PATTERSON MAP C C....METHOD: VALUE AT EACH POINT IS MINIMUM OF VALUES OF PATTERSON FUNCTION C AT THE (NHARK) HARKER VECTORS ASSOCIATED WITH THIS POINT. C C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C....NOTICE THIS EQUIVALENCE: IT ALLOWS US NOT TO HAVE TO MOVE C A COUPLE INTEGERS AROUND SO MUCH C EQUIVALENCE (II,IMIN(1)),(JJ,JMIN(1)),(KK,KMIN(1)) C C C...NZZE=NZS IF IHOLD =1, NZE IF IHOLD=0 C NPMAX=100 NZZE=NZS+ (1-IHOLD(3))*(NZE-NZS) NYYE=NYS+ (1-IHOLD(2))*(NYE-NYS) NXXE=NXS+ (1-IHOLD(1))*(NXE-NXS) C C..DETERMINE # OF DEGREES OF FREEDOM (I.E., NUMBER OF INDEPENDENT POINTS C LOOKED AT) IN THIS SEARCH. IN CASE WHERE ALL THREE AXIS ARE FIXED,FOR C EXAMPLE, THE TOTAL NUMBER OF POSITIONS IN REAL CELL (SEARCH GRID POINTS) C WHICH GIVE INDEPENDENT SETS OF HARKER VECTORS IS ROUGHLY NFREE,THE C TOTAL NUMBER OF DEGREES OF FREEDOM IN THE MAP. C A=ALPHA*FLOAT(ICELL(1)) B=ALPHA*FLOAT(ICELL(2)) C=ALPHA*FLOAT(ICELL(3)) IF(IHOLD(1).EQ.1)A=1. IF(IHOLD(2).EQ.1)B=1. IF(IHOLD(3).EQ.1)C=1. NSRCH=INT(A*B*C+0.5) IF(NSRCH.LT.1)NSRCH=1 C C...DETERMINE # OF GRID POINTS IN EACH DIRECTION C 10 NX=(NXXE-NXS)/2+3 NY=(NYYE-NYS)/2+3 NZ=(NZZE-NZS)/2+1 C IF(NXS.NE.0 .OR. NYS.NE.0 .OR. NZS.NE.0)GO TO 20 C C....CHECK AND SEE IF THE SEARCH REGION IS LARGER THAN REGION C SUPPLIED FOR PATTERSON INPUT MAP. IF IT IS, THEN SUBSTITUTE C REGION FOR PATTERSON INPUT MAP HERE, AS IT IS ALWAYS SUFFICIENT. C IF(NX1*NY1*NZ1 .GE. (NX-2)*(NY-2)*NZ)GO TO 20 C NXXE=2*NPATXE NYYE=2*NPATYE NZZE=2*NPATZE GO TO 10 C 20 IF(NSIGNF.EQ.0)CUTOFF=AMNSYM*SIGMA*CUT(NEQUIV*NCRMAX-1 1 ,NSRCH,.1*SSIN) C C..CUTOFF IS MINIMUM VALUE OF MINIMUM FUNCTION WHICH IS LIKELY TO HAVE C A PROBABILITY OF LESS THAN (1-SSIN) OF BEING DUE TO CHANCE. ANY POINT C WHICH HAS A VALUE OF LESS THAN OR EQUAL TO CUTOFF IS SET TO ZERO. C IF(NSIGNF.NE.0)CUTOFF=0.0 NPEAK=0 IF(NHARK.EQ.0 .AND.NQNCR.EQ.0)RETURN C C..SET UP PEAK LIST C CALL SAVEP(-1) C C...GO THROUGH SECTIONS, LOOK AT EVERY OTHER GRID POINT AT FIRST C DO 2000 KK=NZS,NZZE,2 C INDX=0 DO 1000 JJ=NYS-2,NYYE+2,2 C DO 1000 II=NXS-2,NXXE+2,2 INDX=INDX+1 C NMIN=1 CALL MINIM(1,AMAP(INDX)) 1000 CONTINUE C C...THAT'S IT FOR THIS SECTION. GET PEAKS ON THIS SECTION C CALL SECPK(NXXE,NYYE,KK) C 2000 CONTINUE C C...NOW SEE IF NEARBY GRID POINTS WOULD BE BETTER THAN ANY CURRENT PEAKS C C...MOVE PEAKS INTO ARRAY PEAK C CALL SAVEP(2) C C..INITIALIZE STORAGE ROUTINE C CALL SAVEP(-1) C CUTOFF = -1.E+30 DO 1800 I=1,NPEAK ABEST=0.0 IBEST=0 JBEST=0 KBEST=0 C DO 1750 I1=-(1-IHOLD(1)),(1-IHOLD(1)) DO 1750 J1=-(1-IHOLD(2)),(1-IHOLD(2)) DO 1750 K1=-(1-IHOLD(3)),(1-IHOLD(3)) NMIN=1 II=I1+IPXYZ(1,I) JJ=J1+IPXYZ(2,I) KK=K1+IPXYZ(3,I) CALL MINIM(1,A) IF(A.LE.ABEST)GO TO 1750 ABEST=A IBEST=I1 JBEST=J1 KBEST=K1 C 1750 WRITE(6,*)' PEAK#=',I,' II,JJ,KK=',II,JJ,KK,' ABEST=',ABEST 1750 CONTINUE C CALL SAVEP(0,IBEST+IPXYZ(1,I),JBEST+IPXYZ(2,I),KBEST+IPXYZ(3,I), 1 ABEST,0.,0) 1800 CONTINUE C C C...REWRITE PEAKS INTO ARRAY PEAK AND DELETE ALL DUPLICATIONS C CALL SAVEP(1) C C...SAVE HIGHEST VALUE OF MINIMUM FUNCTION FOR TEST IN DOUBLE C SHI=0.0 IF(NPEAK.EQ.0)GO TO 2002 SHI=PEAK(1) C C..PUT ALL PEAKS IN SEARCH REGION C DO 1801 I=1,NPEAK 1801 CALL INSIDE(IPXYZ(1,I),IPXYZ(2,I),IPXYZ(3,I)) C C...CALCULATE PROBABILITY OF EACH PEAK ARISING BY CHANCE AND C..ELIMINATE PEAKS WHICH ARE LIKELY TO BE DUE TO RANDOM NOISE C C IF(NSIGNF.EQ.0 )CUTOFF=SIGMA*CUT(NEQUIV*NCRMAX-1, 1 NSRCH,SSIN) IF(NSIGNF.EQ.0 )CALL SRTSIG(NSRCH,1,SSIN,1) C IF(NPEAK.GT.0)GO TO 2100 2002 WRITE(6,2001) 2001 FORMAT(//,1X,'NO PEAKS FOUND IN SINGLE-ATOM SEARCH') NPEAK1=0 NPEAK2=0 NSING=0 RETURN C 2100 CONTINUE C C...ELIMINATE DUPLICATION DUE TO CENTERING OR INVERSION. C IF(NQNCR.NE.0)GO TO 2042 NP=0 DO 2050 I=1,NPEAK IF(NP.EQ.0)GO TO 2040 DO 2030 J=1,NP DO 2030 INV=1,-1,-2 DO 2030 IOR=1,NORIG CALL SAMER(INV*(IPXYZ(1,I)+IORIG(1,IOR)), 1 INV*(IPXYZ(2,I)+IORIG(2,IOR)), 1 INV*(IPXYZ(3,I)+IORIG(3,IOR)), 1 IPXYZ(1,J),IPXYZ(2,J),IPXYZ(3,J),ISAME) 2030 IF(ISAME.EQ.1)GO TO 2050 2040 NP=NP+1 PEAK(NP)=PEAK(I) PEAKA(NP)=PEAKA(I) DO 2041 L=1,3 2041 IPXYZ(L,NP)=IPXYZ(L,I) 2050 CONTINUE NPEAK=NP C C...SORT PEAKS ON SPECIAL OR GENERAL POSITIONS. C 2042 CALL SORT(1,0) C C...COPY PEAKS INTO ARRAY ISING FOR LATER USE C NSING=0 IF(NPEAK1.LT.1)GO TO 2025 DO 2024 I=1,NPEAK1 NSING=NSING+1 DO 2024 L=1,3 2024 ISING(L,NSING)=IPXYZ1(L,I) 2025 IF(NPEAK2.LT.1)GO TO 2029 DO 2028 I=1,NPEAK2 NSING=NSING+1 DO 2028 L=1,3 2028 ISING(L,NSING)=IPXYZ2(L,I) 2029 CONTINUE C C...WRITE OUT RESULTS C IF(NPEAK1.LT.1)GO TO 2200 WRITE(6,2101) 2101 FORMAT(//,' FOR EACH TRIAL SOLUTION IN SEARCHES, THE', 1 ' "HEIGHT" IS THE MIMINUM VALUE, OVER ALL', 1 ' PREDICTED PATTERSON VECTORS, OF:',/,1X, 1 '(VALUE OF THE PATT FN)/(THE # OF PREDICTED VECTORS WHICH', 1 ' FALL ON THIS POINT) ',//,1X,' THE SYMMETRY NUMBER IS THE', 1 ' SYMMETRY OF THIS POSITION IN THE PATT FN.') C WRITE(6,2103) 2103 FORMAT(//,' LIST OF MAJOR PEAKS IN SINGLE-ATOM SEARCH:', 1 'GENERAL POSITIONS',//, 1 3X,'PEAK',9X,'X',9X,'Y',9X,'Z',8X,'HEIGHT ', 1 'PROB THAT THIS IS BY CHANCE',/) C WRITE(6,2102)(I,(FLOAT(IPXYZ1(L,I))/FLOAT(ICELL(L)),L=1,3), 1 PEAK1(I),PEAK1A(I),I=1,NPEAK1) 2102 FORMAT(I6,4X,3F10.3,G15.5,5X,F10.3) C 2200 IF(NPEAK2.LT.1)GO TO 8000 WRITE(6,2201) 2201 FORMAT(//,' LIST OF MAJOR PEAKS IN SINGLE-ATOM SEARCH:', 1 'SPECIAL POSITIONS',//, 1 3X,'PEAK',9X,'X',9X,'Y',9X,'Z',9X,'HEIGHT',4X,'SYMM # ', 1 'PROB THAT THIS IS BY CHANCE',/) C WRITE(6,2202)(I+NPEAK1,(FLOAT(IPXYZ2(L,I))/FLOAT(ICELL(L)) 1 ,L=1,3), 1 PEAK2(I),ISYMM(I),PEAK2A(I),I=1,NPEAK2) 2202 FORMAT(I6,4X,3F10.3,G15.5,I6,5X,F10.3) C 8000 WRITE(6,8001) 8001 FORMAT('1') RETURN END SUBROUTINE DOUBLE C C...FUNCTION: C C...CARRIES OUT SEARCH OVER SUPPLIED GRID FOR TWO-ATOM SOLUTION TO PATTERSON C FUNCTION. SECOND ATOM IS RELATED TO FIRST ATOM BY CROSS-VECTOR ICROSS C SUPPLIED FROM EARLIER ROUTINE, WHERE ICROSS= (I2,J2,K2) C...SPACE GROUP SYMMETRY IS EXPLICITLY APPLIED IN THIS SEARCH C C...PROCEDURE: AT GRID POINT (II,JJ,KK) TAKE MINIMUM OF : C C (1) VALUES OF PATTERSON AT HARKER VECTORS DUE TO ATOM AT (II,JJ,KK) C (2) VALUES OF PATTERSON AT HARKER VECTORS DUE TO ATOM AT (II+I2,JJ+J2,KK+K2) C (3) VALUES OF PATTERSON AT EACH CROSS VECTOR BETWEEN EACH POSITION C EQUIVALENT TO (II,JJ,KK) AND EACH POSITION EQUIVALENT TO (II+I2,JJ+J2,KK+K2) C C..FOR SPACE GROUPS IN WHICH THE COORDINATES OF THE ORIGIN ARE UNDEFINED ALONG C ONE OR MORE AXES, DON'T BOTHER TO SEARCH ALONG THESE AXES C C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C...LOCAL VARIABLES C DIMENSION ITST(3),IEQUIV(3),LIMAP(2,3) EQUIVALENCE(LIMAP(1),NXS) C C...ANOTHER EQUIVALENCE OF II,JJ,KK: C EQUIVALENCE (II,IMIN(1)),(JJ,JMIN(1)),(KK,KMIN(1)) C C C...DETERMINE ACTUAL GRID BOUNDARIES C NPMAX=50 C C..IHOLD(I)= FLAG FOR AXIS WHICH ARE INDETERMINATE C NZZE=NZS+ (1-IHOLD(3))*(NZE-NZS) NYYE=NYS+ (1-IHOLD(2))*(NYE-NYS) NXXE=NXS+ (1-IHOLD(1))*(NXE-NXS) C 10 NZ=(NZZE-NZS)/2+1 NY=(NYYE-NYS)/2+3 NX=(NXXE-NXS)/2+3 C IF(NZS.NE.0 .OR. NYS.NE.0 .OR. NXS.NE.0)GO TO 20 C C...ASYMMETRIC UNIT OF THIS SEARCH = ASYMMETRIC UNIT OF PATTERSON MAP C..IF IT HELPS, USE THOSE GRID BOUNDARIES, NOT THOSE INPUT BY USER. C IF(NX1*NY1*NZ1 .GE. (NX-2)*(NY-2)*NZ )GO TO 20 NZZE=NPATZE*2 NYYE=NPATYE*2 NXXE=NPATXE*2 GO TO 10 C 20 A=ALPHA*FLOAT(ICELL(1))*2. B=ALPHA*FLOAT(ICELL(2))*2. C=ALPHA*FLOAT(ICELL(3))*2. IF(IHOLD(1).EQ.1)A=1. IF(IHOLD(2).EQ.1)B=1. IF(IHOLD(3).EQ.1)C=1. C C...SEARCH REGION FOR THIS ROUTINE IS HALF ASYMMETRIC UNIT IF C ALL THREE AXIS ARE FIXED. IN THIS CASE EACH SET OF CROSS VECTORS C IS LOOKED AT ONCE, BUT EACH SET OF HARKER VECTORS IS LOOKED AT C 2*2*2/2=4 TIMES. THE NUMBER OF INDEPENDENT SETS OF SELF+CROSS C VECTORS IS 4*NFREE. C C IN THE CASE WHERE ONE OR MORE AXIS ARE NOT FIXED, SEARCH REGION C IS 1-DIMENSIONAL IN THOSE DIRECTIONS. C NSRCH=INT( 0.5 * A*B*C +0.5) IF(NSRCH.LE.0)NSRCH=1 C C...TEST TO SEE IF THIS SEARCH CAN POSSIBLY FIND A SOLUTION WITH C REQUIRED CERTAINTY OF BEING NON-RANDOM C IF(ITYPE.NE.5 .OR. NSIGNF.NE.0)GO TO 30 CUTOFF=SIGMA*CUT(NEQUIV*NCRMAX*3-3,NSRCH,SDUB) IF(SHI.GE.CUTOFF)GO TO 30 C WRITE(6,40)SHI,CUTOFF,1.-SDUB,1.-PROB(NEQUIV*NCRMAX*3-3,NSRCH, 1 SHI/AMAX1(1.E-10,SIGMA)) C 40 FORMAT(///,1X,'**** MAXIMUM VALUE OF MINUMUM FUNCTION FOUND IN' 1 ' SEARCH OF HARKER VECTORS IS (',G15.5,'), TOO SMALL TO',/,1X, 1 'EXPECT TO FIND ANY TWO-SITE SOLUTIONS WHICH HAVE THE' 1 ' REQUIRED VALUE OF ',G15.5,' IN ORDER TO ',/,1X, 1 'HAVE A PROBABILITY OF LESS THAN ',F10.3,' OF BEING', 1 ' DUE TO SPURIOUS PEAKS IN PATTERSON.',/,1X, 1 'MINIMUM PROBABILITY POSSIBLE WITH THIS VALUE OF FUNCTION', 1 ' IN TWO-SITE SEARCH IS ',F10.3,' ****') STOP C C C...CARRY OUT SEARCH USING EACH SUPPLIED CROSS VECTOR INDIVIDUALLY C 30 IF(NCROSS.EQ.0)RETURN C DO 5000 ITRY=1,NCROSS I2=ICROSS(1,ITRY) J2=ICROSS(2,ITRY) K2=ICROSS(3,ITRY) C WRITE(6,1)ITRY,(FLOAT(ICROSS(L,ITRY))/FLOAT(ICELL(L)),L=1,3) C 1 FORMAT(//,1X,'TWO-ATOM ORIGIN SEARCH. TRY #' 1 ,I2,' . CROSS-VECTOR BETWEEN SITES = (', 1 F5.3,',',F5.3,',',F5.3,')',/) C IF(NSIGNF.NE.0)CUTOFF=0.0 IF(NSIGNF.EQ.0)CUTOFF=SIGMA * CUT(3*NEQUIV*NCRMAX-3,NSRCH 1 ,.1*SDUB) IF(NHARK.GT.0 .OR.NQNCR.NE.0)GO TO 2 C C...HERE FOR P1, JUST USE (0,0,0) AS SOLUTION. C NPEAK=1 DO 3 L=1,3 3 IPXYZ(L,1)=0 CALL PATT(I2,J2,K2,A) PEAK(1)=A GO TO 2100 C C...ALL OTHER SPACE GROUPS C 2 NPEAK=0 C C...SET UP PEAK LIST CALL SAVEP(-1) C DO 2000 KK=NZS,NZZE,2 C INDX=0 DO 1000 JJ=NYS-2,NYYE+2,2 C DO 1000 II=NXS-2,NXXE+2,2 C INDX=INDX+1 C NMIN=2 IMIN(1+NEQUIV)=II+I2 JMIN(1+NEQUIV)=JJ+J2 KMIN(1+NEQUIV)=KK+K2 C C...FIND MINIMUM VALUE OF SELF AND CROSS-VECTORS FOR THESE TWO SITES C CALL MINIM(2,AMAP(INDX)) 1000 CONTINUE C C...ALL DONE WITH THIS SECTION, GET PEAKS C CALL SECPK(NXXE,NYYE,KK) C 2000 CONTINUE C C..REWRITE PEAKS INTO ARRAY PEAK C CALL SAVEP(2) C C...NOW ADJUST PEAKS IF IT HELPS C CALL SAVEP(-1) C NPMAX=100 C CUTOFF=-1.E+30 DO 1800 I=1,NPEAK ABEST=0.0 IBEST=0 JBEST=0 KBEST=0 C DO 1750 I1=-(1-IHOLD(1)),(1-IHOLD(1)) DO 1750 J1=-(1-IHOLD(2)),(1-IHOLD(2)) DO 1750 K1=-(1-IHOLD(3)),(1-IHOLD(3)) C NMIN=2 II=I1+IPXYZ(1,I) JJ=J1+IPXYZ(2,I) KK=K1+IPXYZ(3,I) IMIN(1+NEQUIV)=II+I2 JMIN(1+NEQUIV)=JJ+J2 KMIN(1+NEQUIV)=KK+K2 CALL MINIM(2,RHO) IF(RHO.LE.ABEST)GO TO 1750 ABEST=RHO IBEST=I1 JBEST=J1 KBEST=K1 1750 CONTINUE C CALL SAVEP(0,IBEST+IPXYZ(1,I),JBEST+IPXYZ(2,I),KBEST+IPXYZ(3,I), 1 ABEST,0.,0) 1800 CONTINUE C C C...REWRITE PEAKS INTO ARRAY PEAK AND DELETE ALL DUPLICATIONS C CALL SAVEP(1) C C...ADJUST CROSS-VECTOR BETWEEN SITES SLIGHTLY TO MAXIMIZE MINIMUM FUNCTION C IF(NPEAK.LT.1)GO TO 2002 DO 1900 I=1,NPEAK DO 1900 L=1,3 1900 IP0(L,I)=IPXYZ(L,I)+ICROSS(L,ITRY) C CUTOFF=-1.E+30 CALL MAXIM C C...PUT ALL COORDINATES INSIDE ASYMMETRIC UNIT IF POSSIBLE C DO 1801 I=1,NPEAK CALL INSIDE(IPXYZ(1,I),IPXYZ(2,I),IPXYZ(3,I)) 1801 CALL INSIDE(IP0(1,I),IP0(2,I),IP0(3,I)) C C..RESORT PEAKS ON BASIS OF LIKELIHOOD OF BEING NON-RANDOM C CONTINUE IF(NSIGNF.EQ.0)CUTOFF=SIGMA*CUT(NEQUIV*NCRMAX*3-3,NSRCH,SDUB) IF(NSIGNF.EQ.0)CALL SRTSIG(NSRCH,2,SDUB,2) C C...ALL DONE WITH THIS TRY. WRITE OUT RESULTS C IF(NPEAK.GT.0)GO TO 2100 2002 WRITE(6,2001) 2001 FORMAT(/,1X,'NO PEAKS FOUND IN THIS SEARCH') NPEAK1=0 NPEAK2=0 GO TO 5000 C 2100 CALL SORT(1,1) C IF(ITYPE.EQ.5)GO TO 4880 C C...WRITE OUT RESULTS FOR THIS TRY C IF(NPEAK1.LT.1)GO TO 2200 WRITE(6,2101) 2101 FORMAT(//,' LIST OF MAJOR PEAKS IN THIS SEARCH:', 1 'GENERAL POSITIONS',//, 1 3X,'PEAK',9X,'X1',8X,'Y1',8X,'Z1',8X, 1 5X,'X2',8X,'Y2',8X,'Z2',8X,'HEIGHT ', 1 ' PROB THIS IS BY CHANCE',/) C WRITE(6,2102)(I,(FLOAT(IPXYZ1(L,I))/FLOAT(ICELL(L)),L=1,3), 1 (FLOAT(IP1(L,I))/FLOAT(ICELL(L)),L=1,3), 1 PEAK1(I),PEAK1A(I),I=1,NPEAK1) 2102 FORMAT(I6,4X,3F10.3,5X,3F10.3,G15.5,5X,F10.3) C 2200 IF(NPEAK2.LT.1)GO TO 4870 WRITE(6,2201) 2201 FORMAT(//,' LIST OF MAJOR PEAKS IN THIS SEARCH:', 1 'SPECIAL POSITIONS',//, 1 3X,'PEAK',8X,'X1',8X,'Y1',8X,'Z1',8X, 1 5X,'X2',8X,'72',8X,'Z2',8X,'HEIGHT',4X,'SYMM # ', 1 'PROB THIS IS BY CHANCE',/) C WRITE(6,2202)(I,(FLOAT(IPXYZ2(L,I))/FLOAT(ICELL(L)),L=1,3), 1 (FLOAT(IP2(L,I))/FLOAT(ICELL(L)),L=1,3), 1 PEAK2(I),ISYMM(I),PEAK2A(I),I=1,NPEAK2) 2202 FORMAT(I6,4X,3F10.3,5X,3F10.3,G15.5,I6,5X,F10.3) C 4870 WRITE(6,4871) 4871 FORMAT('1') GO TO 5000 C C C...FOR ITYPE=5, LOOK FOR OTHER SOLUTIONS RELATED TO MAJOR PEAK FOUND IN C..THIS SEARCH C C 4880 NSOLN=2 IF(NPEAK1.EQ.0)GO TO 4888 DO 4890 L=1,3 ISOLN(L,1)=IPXYZ1(L,1) 4890 ISOLN(L,2)=IP1(L,1) WSOLN(1)=PEAK1A(1) WSOLN(2)=PEAK1A(1) AA=PEAK1A(1) GO TO 4895 4888 DO 4891 L=1,3 ISOLN(L,1)=IPXYZ2(L,1) 4891 ISOLN(L,2)=IP2(L,1) WSOLN(1)=PEAK2A(1) WSOLN(2)=PEAK2A(1) AA=PEAK2A(1) 4895 CONTINUE C C C...WRITE OUT RESULT C WRITE(6,4896)((FLOAT(ISOLN(L,I))/FLOAT(ICELL(L)) 1 ,L=1,3),I=1,2),AA 4896 FORMAT(/,1X,'MAXIMUM AGREEMENT FOUND IN SEARCH WITH' 1 ,' THE TWO SITES:',/, 1 1X, '(',F5.3,',',F5.3,',',F5.3, 1 ') AND (',F5.3,',',F5.3,',',F5.3, 1 '). ',/,1X, 1 'PROBABILITY THAT THIS PAIR OF SITES CORRESPONDS TO CHANCE PEAKS =' 1 F5.3) C C C...NOW SEE IF TWO SOLUTIONS SHARE THEIR HARKER VECTORS C C...(DON'T DO THIS TEST IF WE ARE USING SIGNIFICANCE TESTS) C 4900 IF(NSIGNF.EQ.0)GO TO 4909 C CALL SAMEH(ISOLN(1,1),ISOLN(2,1),ISOLN(3,1), 1 ISOLN(1,2),ISOLN(2,2),ISOLN(3,2),ISAME) C IF(ISAME.EQ.0)GO TO 4909 C C...ONLY USE ONE SOLUTION C 4905 NSOLN=1 WRITE(6,4906) 4906 FORMAT(/,1X,'TWO SOLUTIONS FOUND IN TWO-ATOM SEARCH SHARE ALL', 1 ' HARKER VECTORS: FIRST ONE USED.') C C...GENERATE ALL NON-CRYSTALLOGRAPHICALLY EQUIVALENT POSITIONS AND C ELIMINATE DUPLICATIONS. C 4909 IF(NQNCR.EQ.0)GO TO 4926 C NMIN=0 NCUR=1 DO 4920 I=1,NSOLN NMIN=NMIN+1 IMIN(NCUR)=ISOLN(1,I) JMIN(NCUR)=ISOLN(2,I) KMIN(NCUR)=ISOLN(3,I) 4920 NCUR=NCUR+NEQUIV C C...GENERATE NON-CRYST SYMMETRY C CALL MINIM(-1,RHO) C C..TEST TO SEE IF NEW ONES HAVE BEEN ADDED C IF(NMIN.EQ.NSOLN)GO TO 4926 C NS=NSOLN NCUR=NSOLN*NEQUIV+1 DO 4925 I=NSOLN+1,NMIN NS=NS+1 ISOLN(1,NS)=IMIN(NCUR) ISOLN(2,NS)=JMIN(NCUR) ISOLN(3,NS)=KMIN(NCUR) 4925 NCUR=NCUR+NEQUIV C NSOLN=NS C C...NOW ELIMINATE DUPLICATIONS C 4926 NS=1 DO 4930 I=2,NSOLN DO 4928 J=1,NS CALL SAMER(ISOLN(1,J),ISOLN(2,J),ISOLN(3,J), 1 ISOLN(1,I),ISOLN(2,I),ISOLN(3,I),ISAME) 4928 IF(ISAME.EQ.1)GO TO 4930 C C...HERE THIS POINT IS DIFFERENT C NS=NS+1 DO 4929 L=1,3 4929 ISOLN(L,NS)=ISOLN(L,I) WSOLN(NS)=WSOLN(1) 4930 CONTINUE NSOLN=NS C C...PUT ALL SOLUTIONS INTO ASYMMETRIC UNIT, IF POSSIBLE. C 4939 DO 4941 I=1,NSOLN 4941 CALL INSIDE(ISOLN(1,I),ISOLN(2,I),ISOLN(3,I)) C 4970 CONTINUE C C...GET A SET OF SOLUTIONS WHICH HAVE NON-NEGATIVE SELF AND CROSS-VECTORS WITH C ALL OTHER MEMBERS OF THE SET C CALL SIFT C C 5000 CONTINUE C RETURN END SUBROUTINE TRIPLE(IFLAG) C C...FUNCTION: C C....LOCATES SITES WHICH HAVE POSITIVE SELF AND CROSS VECTORS WITH KNOWN C ATOMIC SITES. SPACE GROUP SYMMETRY EXPLICITLY APPLIED. C LIST OF KNOWN SITES IS CONTAINED IN ARRAY ISOLN. C C....VALUE AT GRID POINT (II,JJ,KK) IS MIMINUM OF: C C (1) VALUE OF PATTERSON AT HARKER VECTORS DUE TO SITE (II,JJ,KK) C (2) TO (NSOLN+1) VALUE OF CROSS VECTORS BETWEEN SITE (II,JJ,KK) C (AND ALL SYMMETRY-RELATED SITES) AND EACH C KNOWN SITE (AND ALL SYMMETRY-RELATED SITES) C C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C...LOCAL VARIABLES. C C DIMENSION ISAVE(24),JSAVE(24),KSAVE(24),IR(216),IT(72) C EQUIVALENCE (IR(1),IROT(1)),(IT(1),ITRANS(1)) C EQUIVALENCE (ISAVE(1),II),(JSAVE(1),JJ),(KSAVE(1),KK) C C...TRICKY EQUIVALENCE C EQUIVALENCE (II,IMIN(1)),(JJ,JMIN(1)),(KK,KMIN(1)) C C C...ALWAYS LOOK THROUGH ENTIRE SEARCH REGION HERE. C NPMAX=100 C NX=(NXE-NXS)/2+3 NY=(NYE-NYS)/2+3 NZ=(NZE-NZS)/2+1 C C...ESTIMATE NUMBER OF INDEPENDENT POINTS LOOKED AT HERE. IT WILL BE C NFREE* 2**(NUMBER OF AXIS WHICH ARE FIXED) C A=2. B=2. C=2. IF(IHOLD(1).EQ.1)A=1. IF(IHOLD(2).EQ.1)B=1. IF(IHOLD(3).EQ.1)C=1. C NSRCH=NFREE*INT(A*B*C+0.5) IF(NSRCH.LE.0)NSRCH=1 C IF(NSIGNF.NE.0 .OR. ITYPE.EQ.5)CUTOFF=0.0 IF(NSIGNF.EQ.0 .AND. ITYPE.NE.5) 1 CUTOFF=SIGMA * CUT((NSOLN+1)*(NEQUIV*NCRMAX)- 1 NCRMAX,NSRCH,.1*STRP) NPEAK=0 C C..SET UP PEAK LIST C CALL SAVEP(-1) C DO 2000 KK=NZS,NZE,2 C INDX=0 DO 1000 JJ=NYS-2,NYE+2,2 C DO 1000 II=NXS-2,NXE+2,2 INDX=INDX+1 C NMIN=1 CALL MINIM(3,AMAP(INDX)) 1000 CONTINUE C C...ALL DONE WITH THIS SECTION, GET PEAKS C CALL SECPK(NXE,NYE,KK) 2000 CONTINUE CALL SAVEP(2) C C C...NOW SEE IF SHIFTING POSITIONS SLIGHTLY IMPROVES MINIMUM C CALL SAVEP(-1) C CUTOFF = -1.E+30 DO 1800 I=1,NPEAK ABEST=0.0 IBEST=0 JBEST=0 KBEST=0 C DO 1750 I1=-(1-IHOLD(1)),(1-IHOLD(1)) DO 1750 J1=-(1-IHOLD(2)),(1-IHOLD(2)) DO 1750 K1=-(1-IHOLD(3)),(1-IHOLD(3)) C NMIN=1 II=I1+IPXYZ(1,I) JJ=J1+IPXYZ(2,I) KK=K1+IPXYZ(3,I) CALL MINIM(3,A) IF(A.LE.ABEST)GO TO 1750 ABEST=A IBEST=I1 JBEST=J1 KBEST=K1 1750 CONTINUE C CALL SAVEP(0,IBEST+IPXYZ(1,I),JBEST+IPXYZ(2,I),KBEST+IPXYZ(3,I), 1 ABEST,0.,0) 1800 CONTINUE C C C...REWRITE PEAKS INTO ARRAY PEAK C CALL SAVEP(1) C C DO 1801 I=1,NPEAK 1801 CALL INSIDE(IPXYZ(1,I),IPXYZ(2,I),IPXYZ(3,I)) C C...NOW SORT PEAKS ON BASIS OF PROBABILITY OF BEING NON-RANDOM C C C...ELIMINATE PEAKS WHICH ARE SAME AS CURRENT SOLUTIONS C NP=0 DO 1780 I=1,NPEAK DO 1770 J=1,NSOLN CALL SAMER(ISOLN(1,J),ISOLN(2,J),ISOLN(3,J), 1 IPXYZ(1,I),IPXYZ(2,I),IPXYZ(3,I),ISAME) 1770 IF(ISAME.EQ.1)GO TO 1780 NP=NP+1 PEAK(NP)=PEAK(I) DO 1775 L=1,3 1775 IPXYZ(L,NP)=IPXYZ(L,I) 1780 CONTINUE NPEAK=NP C CUTOFF=SIGMA*CUT( NEQUIV*NCRMAX*(NSOLN+1)- 1 NCRMAX,NSRCH,STRP) IF(NSIGNF.EQ.0 .AND. ITYPE.EQ.4) 1 CALL SRTSIG(NSRCH,1,STRP,3) C C...ALL DONE WITH THIS TRY. WRITE OUT RESULTS C IF(NPEAK.GT.0)GO TO 2100 NPEAK1=0 NPEAK2=0 WRITE(6,2001) 2001 FORMAT(/,1X,'NO PEAKS FOUND IN THIS SEARCH FOR ADDITIONAL' 1 ,'SITES') GO TO 5000 C 2100 CALL SORT(1,0) C IF(IFLAG.EQ.0)GO TO 5000 C IF(NPEAK1.LT.1)GO TO 2200 WRITE(6,2101) 2101 FORMAT(//,' LIST OF MAJOR PEAKS IN THIS SEARCH:', 1 'GENERAL POSITIONS',//, 1 3X,'PEAK',9X,'X',9X,'Y',9X,'Z',8X,'HEIGHT', 1' PROB THAT THIS IS BY CHANCE',/) C WRITE(6,2102)(I,(FLOAT(IPXYZ1(L,I))/FLOAT(ICELL(L)),L=1,3), 1 PEAK1(I),PEAK1A(I),I=1,NPEAK1) 2102 FORMAT(I6,4X,3F10.3,G15.5,5X,F10.3) C 2200 IF(NPEAK2.LT.1)GO TO 4998 WRITE(6,2201) 2201 FORMAT(//,' LIST OF MAJOR PEAKS IN THIS SEARCH:', 1 'SPECIAL POSITIONS',//, 1 3X,'PEAK',9X,'X',9X,'Y',9X,'Z',9X,'HEIGHT',4X,'SYMM #', 1 ' PROB THAT THIS IS BY CHANCE',/) C WRITE(6,2202)(I,(FLOAT(IPXYZ2(L,I))/FLOAT(ICELL(L)),L=1,3), 1 PEAK2(I),ISYMM(I),PEAK2A(I),I=1,NPEAK2) 2202 FORMAT(I6,4X,3F10.3,G15.5,I6,5X,F10.3) C 4998 WRITE(6,4999) 4999 FORMAT('1') C 5000 CONTINUE C RETURN END SUBROUTINE SIFT C C FUNCTION: YIELDS LIST OF SITES IN ARRAY ISOLN WHICH ALL HAVE: C (1) POSITIVE SELF-VECTORS IN PATTERSON FUNCTION C (2) POSITIVE CROSS-VECTORS WITH ALL OTHER SITES (INCLUDING C SPACE-GROUP SYMMETRY IN ALL CASES C C METHOD: (A) BEGINNING WITH AT LEAST ONE KNOWN (OR TEST) SOLUTION IN C ARRAY ISOLN, CALLS SUBROUTINE "TRIPLE" TO GENERATE LIST OF C SITES WHICH HAVE POSITIVE SELF-VECTORS AND POSITIVE CROSS- C VECTORS WITH KNOWN SOLUTIONS. C C THEN, (B), GOES THROUGH POTENTIAL SOLUTIONS FOUND ABOVE, IN C DECREASING ORDER OF (MINIMUM HEIGHT OF SELF-VECTORS AND CROSS C VECTORS WITH KNOWN SITES), BEGINNING WITH SITES ON GENERAL C POSITIONS ONLY. FOR EACH POTENTIAL SOLUTION: C C IF IT HAS POSITIVE CROSS-VECTORS WITH ALL CURRENT "KNOWN" C SOLUTIONS AND IS DISTINCT FROM ALL CURRENT SOLUTIONS C PLACE THIS POTENTIAL SOLUTION IN LIST OF "KNOWN" C SOLUTIONS. C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C...LOCAL VARIABLES C DIMENSION ITST(3,24),JTST(3,24),JTMP(3) DIMENSION ASUM(40),ACROSS(40,40),ISYMCR(40,40) DIMENSION ISMHRK(40),JSMHRK(40),TMPWGT(40),INEW(40) COMMON /NUL2/I00,INEW LOGICAL*1 JSIGN(40),IPLUS,IMINU DATA IPLUS,IMINU / ' ','-'/ DATA I00/0/ DIMENSION ITMP(3),IDEL(3),JSINGL(40),JDEL(3,40) DIMENSION ICUT(100) C IF(NSOLN.LT.1)STOP'CANNOT USE ROUTINE "SIFT" WITHOUT TEST SOLUTIONS.' IF(NSOLN.GE.40)GO TO 1500 C C...IN ANY ONE PASS THROUGH HERE, DON'T ADD MORE THAN 4*NCRMAX NEW SOLUTIONS C INTO LIST C NSFMAX=NSOLN+4*NCRMAX C C...FIRST GET MINIMUM OF SELF AND CROSS VECTORS FOR STARTING SOLUTIONS. C C CUTOFF=-1.E+30 C DO 1 I=1,20 DO 1 J=1,20 1 ACROSS(I,J)=-1.E+30 C DO 7 I=1,NSOLN DO 7 J=1,I CALL CROMIN(ISOLN(1,I),ISOLN(2,I),ISOLN(3,I), 1 ISOLN(1,J),ISOLN(2,J),ISOLN(3,J),A) ACROSS(I,J)=A 7 CONTINUE C DO 6 I=1,NSOLN ISMHRK(I)=0 IF(NSIGNF.NE.0)GO TO 8 IF(I.EQ.1)GO TO 8 DO 9 J=1,I-1 CALL SAMEH(ISOLN(1,I),ISOLN(2,I),ISOLN(3,I), 1 ISOLN(1,J),ISOLN(2,J),ISOLN(3,J),ISAME) IF(ISAME.EQ.0)GO TO 9 ISMHRK(I)=J GO TO 8 9 CONTINUE C 8 IF(ITYPE.EQ.5)GO TO 6 DO 6 J=1,NSOLN ACROSS(I,J)=AMAX1(ACROSS(I,J),ACROSS(J,I)) 6 CONTINUE C NUNIQE=NSOLN C C...SEARCH FOR ADDITIONAL SITES C CUTOFF=-1.E+30 C CALL TRIPLE(0) C C...GO THROUGH PEAKS IN MAP, PUT THEM INTO ISOLN IF THEY ARE NEW AND C...HAVE ALL APPROPRIATE CROSS VECTORS. C C NSRCH=NFREE*(2-IHOLD(1))*(2-IHOLD(2))*(2-IHOLD(3)) 500 CUTOFF=SIGMA*CUT(NCRMAX*NEQUIV*(NSOLN+1)-NCRMAX, 1 NSRCH,SSFT) C C...FIND SITE WHICH HAS HIGHEST CROSS AND SELF VECTORS. C..IF NSIGNF=0, DIVIDE PEAK HEIGHTS BY NUMBER OF TIMES CROSS VECTORS C FALL ON THIS PEAK C 550 ABEST=-1.E+30 APBST=0. IF(NPEAK.EQ.0)GO TO 1500 C DO 570 I=1,NPEAK C C...IF THE PEAK HEIGHT HERE (MINIMUM OF SELF, CROSS VECTORS, NOT DIVIDED C BY REPETITION NUMER) IS LESS THAN ABEST, THIS AND ALL PEAKS BELOW IT C ARE NO LONGER CONTENDERS FOR TOP PEAK SPOT. C IF(PEAK(I).LE.ABEST)GO TO 580 IF(NSIGNF.NE.0)GO TO 555 IMIN(1)=IPXYZ(1,I) JMIN(1)=IPXYZ(2,I) KMIN(1)=IPXYZ(3,I) NMIN=1 CALL ISIGNF(NSRCH,1,3,APROB,SAMIN) IF(APROB.LE.SSFT)GO TO 570 IF(SAMIN.LE.ABEST)GO TO 570 C 555 ABEST=SAMIN APBST=1.-APROB IBEST=I 570 CONTINUE 580 CONTINUE C C...IF NONE OF THESE PEAKS HAD OK CROSS-VECTORS, WE'RE ALL DONE C IF(ABEST.LE.CUTOFF)GO TO 1500 C C...NOW IPXYZ(1-3,IBEST) WAS BEST SOLUTION NMIN=1 IMIN(1)=IPXYZ(1,IBEST) JMIN(1)=IPXYZ(2,IBEST) KMIN(1)=IPXYZ(3,IBEST) C C..EXPAND INTO NON-CRYST SYMMETRY, IF PRESENT C IF(NQNCR.NE.0)CALL MINIM(-1,RHO) C C C...NOW, DOES THIS PEAK SHARE ALL ITS HARKER VECTORS WITH ANY PEAK? C...THIS EXCLUSION WILL ELIMINATE SOME CORRECT SITES, BUT SITES C WHICH SHARE ALL HARKER VECTORS WITH ANOTHER SITE ARE LIKELY TO C BE FALSE SITES> HERE WE FLAG THEM WITH ISMHRK=N C ISMHRK(NSOLN+1)=0 C IF(NQNCR.NE.0)GO TO 100 IF(NOSYM.EQ.1)GO TO 100 IF(NHARK.EQ.0)GO TO 100 C DO 50 K=1,NSOLN IF(ISMHRK(K).NE.0)GO TO 50 CALL SAMEH(ISOLN(1,K),ISOLN(2,K),ISOLN(3,K), 1 IMIN(1),JMIN(1),KMIN(1),ISAME) IF(ISAME.EQ.1)ISMHRK(NSOLN+1)=K 50 CONTINUE C C C...THIS IS A NEW PEAK. PUT IT INTO ISOLN. (ALONG WITH ALL NON-CRYST C SYMMETRY-RELATED POINTS, IF APPLICABLE) C 100 NS=NSOLN+NMIN NSSAVE=NSOLN NCUR=1 DO 800 NN=NSSAVE+1,NS IF(NQNCR.EQ.0)GO TO 730 DO 725 JJ=1,NSOLN CALL SAMER(ISOLN(1,JJ),ISOLN(2,JJ),ISOLN(3,JJ), 1 IMIN(NCUR),JMIN(NCUR),KMIN(NCUR),ISAME) 725 IF(ISAME.EQ.1)GO TO 750 C 730 NSOLN=NSOLN+1 ISOLN(1,NSOLN)=IMIN(NCUR) ISOLN(2,NSOLN)=JMIN(NCUR) ISOLN(3,NSOLN)=KMIN(NCUR) WSOLN(NSOLN)=APBEST IF(NSOLN.EQ.40)GO TO 1500 750 NCUR=NCUR+NEQUIV C 800 IF(NSOLN.GE.NSFMAX.OR. NSOLN.GT.40)GO TO 1500 C C...NOW RECALCULATE MINIMUM FUNCTION FOR ALL PEAKS LEFT IN LIST C AND DELETE ALL THOSE EQUIVALENT TO NEW SOLUTIONS C CALL SAVEP(-1) C CUTOFF=SIGMA*CUT(NCRMAX*NEQUIV*(NSOLN+1)-NCRMAX, 1 NSRCH,SSFT) C DO 900 I=1,NPEAK NMIN=1 IMIN(1)=IPXYZ(1,I) JMIN(1)=IPXYZ(2,I) KMIN(1)=IPXYZ(3,I) CALL MINIM(3,RHO) IF(RHO.LT.CUTOFF)GO TO 900 CALL SAVEP(0,IPXYZ(1,I),IPXYZ(2,I),IPXYZ(3,I),RHO,0.,0) 900 CONTINUE C C...REWRITE PEAKS INTO ARRAY PEAK C CALL SAVEP(1) C C...DELETE REPETITIONS OF SOLUTIONS IN PEAK LIST C ( ONLY NEED TO CHECK NEW SOLUTIONS.) C IF(NPEAK.EQ.0)GO TO 1500 NP=0 DO 970 I=1,NPEAK DO 960 J=NSSAVE+1,NSOLN CALL SAMER(ISOLN(1,J),ISOLN(2,J),ISOLN(3,J), 1 IPXYZ(1,I),IPXYZ(2,I),IPXYZ(3,I),ISAME) 960 IF(ISAME.EQ.1)GO TO 970 NP=NP+1 PEAK(NP)=PEAK(I) DO 965 L=1,3 965 IPXYZ(L,NP)=IPXYZ(L,I) 970 CONTINUE NPEAK=NP C C..CYCLE THROUGH PEAKS ONCE AGAIN C GO TO 550 C C C..ALL DONE C 1500 CONTINUE C C...THE SET OF SOLUTIONS ISOLN CURRENTLY CONTAINS SOME SOLUTIONS WHICH C HAVE THE SAME HARKER VECTORS AS OTHER SOLUTIONS. C THESE ARE FLAGGED WITH ISMHRK > 0. NOW MOVE REPEATS C TO THE BOTTOM OF THE LIST. C IF(NQNCR.NE.0)GO TO 1590 C NUNIQE=0 DO 1400 I=1,NSOLN JSMHRK(I)=0 1400 IF(ISMHRK(I).EQ.0)NUNIQE=NUNIQE+1 C C...NOW PUT ALL THOSE SOLUTIONS WHICH HAVE ISYMHRK > 0 ON END OF LIST C NP=NUNIQE NUNIQE=0 DO 1489 I=1,NSOLN IF(ISMHRK(I).GT.0)GO TO 1300 NUNIQE=NUNIQE+1 JSMHRK(NUNIQE)=0 DO 1301 L=1,3 1301 IPXYZ(L,NUNIQE)=ISOLN(L,I) INEW(I)=NUNIQE TMPWGT(NUNIQE)=WSOLN(I) GO TO 1489 1300 NP=NP+1 JSMHRK(NP)=ISMHRK(I) DO 1351 L=1,3 1351 IPXYZ(L,NP)=ISOLN(L,I) INEW(I)=NP TMPWGT(NP)=WSOLN(I) 1489 CONTINUE C IF(NP.NE.NSOLN)STOP'ERROR IN SIFT' C DO 1580 I=1,NSOLN ISMHRK(I)=INEW(JSMHRK(I) ) WSOLN(I)=TMPWGT(I) DO 1580 L=1,3 1580 ISOLN(L,I)=IPXYZ(L,I) C C...................................................................... C C...SOLUTIONS ISOLN ARE NOW SORTED PROPERLY. C 1590 CONTINUE C C...NOW DETERMINE IF ANY CROSS-VECTORS ARE ON POSITIONS OF SPECIAL C SYMMETRY. C C...ALSO RECALCULATE ALL CROSS VECTOR VALUES. C CUTOFF=-1.E+30 DO 1550 I=1,NSOLN DO 1550 J=1,I CALL CROMIN(ISOLN(1,I),ISOLN(2,I),ISOLN(3,I), 1 ISOLN(1,J),ISOLN(2,J),ISOLN(3,J),A) ACROSS(I,J)=A ACROSS(J,I)=A C CALL CROSPC(ISOLN(1,I),ISOLN(2,I),ISOLN(3,I), 1 ISOLN(1,J),ISOLN(2,J),ISOLN(3,J),ISPEC) ISYMCR(I,J)=ISPEC ISYMCR(J,I)=ISPEC 1550 CONTINUE C C...NOW ANALYZE EACH SITE IN RELATION TO SINGLE-SITE SOLUTIONS (IF ANY). C DO 1799 I=1,NSOLN CALL INSIDE(ISOLN(1,I),ISOLN(2,I),ISOLN(3,I)) 1799 JSINGL(I)=0 C IF(NSING.EQ.0 .OR. NHARK.EQ.0)GO TO 2000 C DO 1900 I=1,NSOLN DO 1810 J=1,NSING C C...DOES SOLUTION I HAVE SAVE HARKER VECTORS AS SINGLE-SITE SOLUTION J? DO 1809 K=1,NHARK DO 1805 L=1,3 INDX=0 DO 1804 LL=1,3 1804 INDX=INDX+IHARKR(L,LL,K)*ISOLN(LL,I) 1805 ITMP(L)=INDX+IHARKT(L,K) C DO 1807 L=1,3 INDX=0 DO 1806 LL=1,3 1806 INDX=INDX+IHARKR(L,LL,K)*ISING(LL,J) 1807 JTMP(L)=INDX+IHARKT(L,K) C CALL SAMEP(ITMP(1),ITMP(2),ITMP(3),JTMP(1),JTMP(2),JTMP(3), 1 ISAME) 1809 IF(ISAME.EQ.0)GO TO 1810 GO TO 1820 1810 CONTINUE JSINGL(I)=0 GO TO 1900 C C...(THIS ONE IS NOT THE SAME AS ANY SINGLE-SITE SOLUTION) C 1820 JSINGL(I)=J C DO 1850 ICENT=1,NCENTR C C...TAKE CARE OF ARBITRARY AXIS C DO 1825 L=1,3 IF(IHOLD(L).EQ.0)ITMP(L)=ISOLN(L,I) IF(IHOLD(L).NE.0)ITMP(L)=ISING(L,J) + ICENTR(L,ICENT) 1825 IDEL(L)=ISOLN(L,I)-ITMP(L) C C...FIND ORIGIN SHIFT AND INVERSION C DO 1850 INV=1,-1,-2 DO 1850 IOR=1,NORIG CALL SAMER(ITMP(1),ITMP(2),ITMP(3), 1 INV*(ISING(1,J)+IORIG(1,IOR)), 2 INV*(ISING(2,J)+IORIG(2,IOR)), 3 INV*(ISING(3,J)+IORIG(3,IOR)),ISAME) 1850 IF(ISAME.EQ.1)GO TO 1860 C C..IF HERE, WE DIDN'T FIND RELATIONSHIP C DO 1851 L=1,3 1851 JDEL(L,I)=0 JSIGN(I)=IPLUS WRITE(6,1852)I,JSINGL(I) 1852 FORMAT(1X,'*****NOTE********** UNABLE TO DETERMININE', 1 ' RELATIONSHIP BETWEEN ',/, 1 ' SOLUTION ',I5,' AND SINGLE-SITE SOLUTION ',I5,/) GO TO 1900 C C..OK. C 1860 DO 1861 L=1,3 1861 JDEL(L,I)=JMOD(INV*IDEL(L)+IORIG(L,IOR)+ILARG(L),ICELL(L) ) JSIGN(I)=IPLUS IF(INV.EQ.-1)JSIGN(I)=IMINU 1900 CONTINUE 2000 CONTINUE C C...ALL DONE. WRITE OUT RESULTS. C C...BUT FIRST, SET ACROSS(I,I)=0 IF NO HARKER VECTORS AND ADD UP C...ACROSS(I,J) FOR EACH SOLUTION C IF(NHARK.GT.0)GO TO 1650 DO 1600 I=1,NSOLN 1600 ACROSS(I,I)=0.0 C 1650 ATOTAL=0.0 DO 1651 I=1,NSOLN 1651 ASUM(I)=0. IF(NQNCR.NE.0)NUNIQE=NSOLN DO 1800 I=1,NUNIQE DO 1800 J=1,NUNIQE AFACT=0.5 IF(I.EQ.J)AFACT=1.0 ASUM(I)=ASUM(I)+ACROSS(I,J) ATOTAL=ATOTAL+ACROSS(I,J)*AFACT 1800 CONTINUE C C WRITE(6,2001) 2001 FORMAT(/,30X,'*********ANALYSIS OF THIS SOLUTION:**********' 1 ,//, 1 3X,'SITE',9X,'X',9X,'Y',9X,'Z',7X,'PROB THAT THIS IS BY CHANCE', 1 7X,'HAS SAME',4X,'CORRESPONDS',5X,'WITH',/,72X, 1 'HARKER VECTORS',2X,'TO SINGLE-',3X,'ORIENTATION',/, 1 72X,'AS SITE:',5X,'SITE SOLN:') C DO 2013 I=1,NSOLN IF(I.EQ.NUNIQE+1)WRITE(6,2014) 2014 FORMAT(/,1X,'SOLUTIONS LISTED BELOW SHARE HARKER VECTORS WITH ',/, 1 1X,'AT LEAST ONE SITE ABOVE YET ARE COMPLETELY CONSISTENT',/, 1 1X,'WITH ABOVE SITES',//) C IF(JSINGL(I).EQ.0)WRITE(6,2011)I,(FLOAT(ISOLN(L,I))/FLOAT(ICELL(L)) 1 ,L=1,3), 1 WSOLN(I),ISMHRK(I) C IF(JSINGL(I).NE.0)WRITE(6,2011)I,(FLOAT(ISOLN(L,I))/FLOAT(ICELL(L)) 1 ,L=1,3), 1 WSOLN(I),ISMHRK(I),JSINGL(I),JSIGN(I) 1 ,(FLOAT(JDEL(L,I))/FLOAT(ICELL(L)),L=1,3) C 2011 FORMAT(I6,4X,3F10.3,8X,F14.3,8X, 1 I10,I12,7X,A1,'(X+',F4.3,' ,Y+',F4.3, 1 ', Z+',F4.3,')') C 2013 CONTINUE C WRITE(6,2021)(I,I=1,JMIN0(10,NSOLN)) 2021 FORMAT(///,1X,'LIST OF CROSS-VECTORS' 1 ' IN PATTERSON FUNCTION ; FIRST TEN ONLY', 1 ' :',//,3X,10(I6,6X)) DO 2030 I=1,JMIN0(10,NSOLN) 2030 WRITE(6,2031)I, 1 (AMIN1(999999.9,AMAX1(-99999.9,ACROSS(I,J))) 1 ,J=1,JMIN0(10,NSOLN)) 2031 FORMAT(/,I3,1X,(10(F8.1,4X))) C WRITE(6,2032) 2032 FORMAT('1') C RETURN END SUBROUTINE SECPK(NXXE,NYYE,KK) C C..FUNCTION: C C...DETERMINES LOCATIONS OF PEAKS ON THIS SECTION. C NEW PEAKS ARE PLACED IN ARRAY PEAK, IPXYZ USING ROUTINE SAVEP C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) DIMENSION NMAP(3),LIMITS(3) EQUIVALENCE (LIMITS(1),NPATXE),(NMAP(1),NX) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C C..LOCAL VARIABLES C DIMENSION ITMP(3),IFLAG(100) C INDX=0 JJJ=0 DO 1000 JJ=NYS,NYYE,2 JJJ=JJJ+1 C INDX=JJJ*NX+1 INDXM1=INDX-1 INDXP1=INDX+1 C DO 1000 II=NXS,NXXE,2 C INDXM1=INDX INDX=INDXP1 INDXP1=INDXP1+1 C F0=AMAP(INDX) IF(F0.LE.CUTOFF)GO TO 1000 C C...IS THIS POINT A LOCAL MAXIMUM ON THIS SECTION? C...IF SEVERAL ADJACENT POINTS HAVE THE SAME HEIGHT (EXACTLY), THEN C ONLY INCLUDE THE FIRST ONE WE COME UPON IN PEAK LIST. FOR THIS C REASON, POINTS ON EDGES MUST BE TREATED SEPARATELY FROM POINTS IN C THE MIDDLE. C C..IF A PORTION OF A SECTION LOOKS LIKE: C C C 1 1 1 1 1 2 2 1 1 1 1 C ........................................... C 1 . 1 1 1 1 1 2 2 1 2 2 1 C . C 1 . 1 1 1 1 1 2 1 1 1 2 1 C . C 1 . 1 1 1 1 1 1 1 1 1 1 1 C . C 1 . 1 1 1 1 1 1 1 1 1 1 1 C C C...WHERE THE DOTTED LINES INDICATE THE PERIMETER OF THE REGION FROM C NXS (TO NXE) ACROSS, AND NYS (TO NYE ) DOWN; THE EXTRA ROW AND C COLUMN OF POINTS ARE JUST TO BE ABLE TO LOCATE MAXIMA ON THE C EDGES. C...IN THIS EXAMPLE, THE FIRST AND THIRD "2" 'S ON THE SECOND LINE WOULD C BE SAVED AS MAXIMA. C C IF(F0 - AMAX1( AMAP(INDXM1),AMAP(INDXM1-NX),AMAP(INDX-NX), 1 AMAP(INDXP1-NX)) )1000,300,301 C 300 IF(II.NE.NXS .AND. JJ.NE.NYS)GO TO 1000 C C (HERE IF F0 IS EQUAL TO AN ADJACENT ELEMENT BUT C II= NXS OR JJ=NYS, THIS IS ON AN EDGE. C 301 IF(F0 .LT. AMAX1( AMAP(INDXP1),AMAP(INDXM1+NX),AMAP(INDX+NX), 1 AMAP(INDXP1+NX)) ) GO TO 1000 C C 210 CALL SAVEP(0,II,JJ,KK,F0,0.,0) 1000 CONTINUE C RETURN END SUBROUTINE SORT(ISORT,JSORT) C C....FUNCTION: C C...SORTS PEAKS IN ARRAY IPXYZ ON BASIS OF GENERAL OR SPECIAL POSITIONS C IF ISORT=0 THEN "SPECIAL" IS WITH RESPECT TO PATTERSON FUNCTION, IF C ISORT=1 THEN "SPECIAL" IS WITH RESPECT TO SPACE GROUP. C...IF JSORT=1, THEN POINT IPXYZ+(IC1,IC2,IC3) WILL ALSO BE TESTED. C C A PEAK IS ON A SPECIAL POSITION IF THERE IS AN OPERATION IN THE GROUP, C OTHER THAN THE IDENTITY, WHICH PLACES THIS PEAK ON ITSELF. C C IF ISORT=1, THEN (FOR PRESENT PURPOSES) A PEAK IS ON A SPECIAL POSITION C IF ANY OF ITS ASSOCIATED HARKER VECTORS ARE ON POSITIONS OF GREATER C THAN NORMAL SYMMETRY IN PATTERSON. C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C NPEAK1=0 NPEAK2=0 IF(NPEAK.EQ.0)RETURN C DO 2000 I=1,NPEAK C ISPEC1=1 ISPEC=1 IF(NOSPEC.EQ.1)GO TO 900 IF(ISORT.EQ.1)GO TO 800 C CALL SPECP(IPXYZ(1,I),IPXYZ(2,I),IPXYZ(3,I),ISPEC) IF(JSORT.NE.0)CALL SPECP(IP0(1,I),IP0(2,I),IP0(3,I),ISPEC1) IF(ISPEC.GT.1.OR.ISPEC1.GT.1)GO TO 1500 GO TO 900 C 800 CALL SPECR(IPXYZ(1,I),IPXYZ(2,I),IPXYZ(3,I),ISPEC) IF(JSORT.NE.0)CALL SPECR(IP0(1,I),IP0(2,I),IP0(3,I),ISPEC1) IF(ISPEC.GT.1.OR.ISPEC1.GT.1)GO TO 1500 C 900 CONTINUE C NPEAK1=NPEAK1+1 PEAK1A(NPEAK1)=PEAKA(I) PEAK1(NPEAK1)=PEAK(I) DO 1100 L=1,3 IP1(L,NPEAK1)=IP0(L,I) 1100 IPXYZ1(L,NPEAK1)=IPXYZ(L,I) GO TO 2000 C 1500 NPEAK2=NPEAK2+1 PEAK2A(NPEAK2)=PEAKA(I) PEAK2(NPEAK2)=PEAK(I) ISYMM(NPEAK2)=JMAX0(ISPEC,ISPEC1) DO 1600 L=1,3 IP2(L,NPEAK2)=IP0(L,I) 1600 IPXYZ2(L,NPEAK2)=IPXYZ(L,I) C 2000 CONTINUE RETURN END SUBROUTINE SPECP(IX,IY,IZ,ISPEC) C C...FUNCTION C C RETURNS ISPEC=N GREATER THAN 1 IF C IX,IY,IZ IS A SPECIAL POSITION IN PATTERSON FUNCTION, C I.E., IF AN OPERATION IN GROUP OTHER THAN THE IDENTITY MAPS (IX,IY,IZ) C ONTO ITSELF, WITHIN TOLERANCE OF NTOL2 C C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C C...LOCAL VARIABLES C DIMENSION ITMP(3),IEQUIV(3) C ITMP(1)=IX ITMP(2)=IY ITMP(3)=IZ C ISPEC=0 C C...DETERMINE EACH POSITION EQUIVALENT TO (IX,IY,IZ) IN PATTERSON CELL C DO 90 J=1,NPROT DO 20 L=1,3 INDX=0 DO 10 LL=1,3 10 INDX=INDX+IPROT(L,LL,J)*ITMP(LL) 20 IEQUIV(L)=INDX C DO 50 K=1,NCENTR DO 30 L=1,3 INDX=JMOD(IEQUIV(L)+ICENTR(L,K)-ITMP(L) +ILARG(L),ICELL(L)) IF(INDX.GT.NTOL2)INDX=ICELL(L)-INDX 30 IF(INDX.GT.NTOL2)GO TO 50 C C...THIS POSITION IS EQUIVALENT TO (IX,IY,IZ) C ISPEC=ISPEC+1 50 CONTINUE 90 CONTINUE RETURN END C SUBROUTINE SPECR(IX,IY,IZ,ISPEC) C C...FUNCTION C C RETURNS ISPEC=N GREATER THAN 1 C IF IX,IY,IZ IS A SPECIAL POSITION IN REAL CELL C (I.E, IF A OPERATION IN GROUP OTHER THAN IDENTITY MAPS (IX,IY,IZ) ONTO C ITSELF). ALSO RETURNS ISPEC=1 IF ANY HARKER VECTOR ASSOCIATED WITH C THE POINT (IX,IY,IZ) IS ON A POSITION OF GREATER-THAN-NORMAL SYMMETRY. C C...ALWAYS USED TOLERANCES OF NTOL2 C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C C...LOCAL VARIABLES C DIMENSION ITMP(3),IEQUIV(3) DATA IFIRST/0/ DATA IMAX,AMNSYM/1,1.0/ C IF(IFIRST.NE.0)GO TO 3100 C C........................................................................... IFIRST=1 IF(NHARK.EQ.0)GO TO 3100 C C..ESTABLISH MAXIMUM SYMMTRY NUMBER FOR A HARKER VECTOR DUE TO ATOM IN A C GENERAL POSITION. C DO 3010 L=1,3 3010 ITMP(L)=IGEN(L) C DO 1100 K=1,NHARK DO 1050 L=1,3 INDX=0 DO 1040 LL=1,3 1040 INDX=INDX+IHARKR(L,LL,K)*ITMP(LL) 1050 IEQUIV(L)=INDX+IHARKT(L,K) C C....WHAT IS THE SYMMETRY NUMBER FOR THIS HARKER VECTOR? C CALL SPECP(IEQUIV(1),IEQUIV(2),IEQUIV(3),ISPEC1) AMNSYM=AMIN1(AMNSYM,FLOAT(ISPEC1)) 1100 IMAX=JMAX0(ISPEC1,IMAX) C C...IMAX IS NOW THE LARGEST SYMMETRY NUMBER FOR A GENERAL HARKER VECTOR. C C............................................................................. C C...HERE FOR NORMAL CALL C 3100 ITMP(1)=IX ITMP(2)=IY ITMP(3)=IZ C ISPEC=0 C DO 900 J=1,NEQUIV DO 200 L=1,3 INDX=0 DO 100 LL=1,3 100 INDX=INDX+IROT(L,LL,J)*ITMP(LL) 200 IEQUIV(L)=INDX+ITRANS(L,J) DO 500 K=1,NCENTR DO 300 L=1,3 INDX=JMOD(IEQUIV(L)+ICENTR(L,K)-ITMP(L) +ILARG(L),ICELL(L)) IF(INDX.GT.NTOL2)INDX=ICELL(L)-INDX 300 IF(INDX.GT.NTOL2)GO TO 500 C ISPEC=ISPEC+1 500 CONTINUE 900 CONTINUE C C...NOW CHECK TO SEE IF HARKER VECTORS ARE IN POSITIONS OF UNUSUAL SYMMETRY. C IF(NHARK.EQ.0)RETURN IF(ISPEC.GT.1)RETURN C DO 1500 K=1,NHARK DO 1450 L=1,3 INDX=0 DO 1440 LL=1,3 1440 INDX=INDX+IHARKR(L,LL,K)*ITMP(LL) 1450 IEQUIV(L)=INDX+IHARKT(L,K) CALL SPECP(IEQUIV(1),IEQUIV(2),IEQUIV(3),ISPEC1) 1500 IF(ISPEC1.GT.IMAX)ISPEC=ISPEC1 RETURN END SUBROUTINE CROSPC(IA,JA,KA,IB,JB,KB,ISPEC) C C...FUNCTION C C RETURNS ISPEC > 1 IF ANY CROSS VECTORS BETWEEN (IA,JA,KA) AND (IB,JB,KB) C FALL ON SPECIAL POSITIONS IN PATTERSON FUNCTION C C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C C...LOCAL VARIABLES C DIMENSION ITMP(3),IEQUIV(3),JTMP(3),JEQUIV(3) C ITMP(1)=IA ITMP(2)=JA ITMP(3)=KA JTMP(1)=IB JTMP(2)=JB JTMP(3)=KB C ISPEC=0 C C...GENERATE ALL PAIRS OF POSITIONS EQUIVALENT TO ITMP,JTMP, DETERMINE C IF THEIR DIFFERENCE IS ON A POSITION OF SPECIAL SYMMETRY IN PATTERSON C DO 1000 IPOS=1,NEQUIV C DO 100 L=1,3 INDX=0 DO 50 LL=1,3 50 INDX=INDX+IROT(L,LL,IPOS)*ITMP(LL) 100 IEQUIV(L)=INDX+ITRANS(L,IPOS) C DO 1000 JPOS=1,NEQUIV C DO 200 L=1,3 INDX=0 DO 150 LL=1,3 150 INDX=INDX+IROT(L,LL,JPOS)*JTMP(LL) 200 JEQUIV(L)=INDX+ITRANS(L,JPOS) C C...IS THE CROSS-VECTOR BETWEEN THESE TWO ON A POSITION OF SYMMETRY? C CALL SPECP(IEQUIV(1)-JEQUIV(1),IEQUIV(2)-JEQUIV(2), 1 IEQUIV(3)-JEQUIV(3),ISP) C 1000 ISPEC=JMAX0(ISPEC,ISP) RETURN END C C SUBROUTINE SAMEP(I1,I2,I3,J1,J2,J3,ISAME) C C FUNCTION: RETURNS ISAME=1 IF (I1,I2,I3) AND (J1,J2,J3) ARE EQUIVALENT C BY PATTERSON SYMMETRY, C WITHIN TOLERANCE NTOL4 C C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C..LOCAL VARIABLES C DIMENSION JTST(3),IEQUIV(3),IR(216) EQUIVALENCE (IEQ1,IEQUIV(1)),(IEQ2,IEQUIV(2)),(IEQ3,IEQUIV(3)), 1 (IR(1),IPROT(1)) C JTST(1)=J1 JTST(2)=J2 JTST(3)=J3 C ISAME=0 C JJST=0 DO 100 J=1,NPROT IEQ1=IR(JJST+1)*I1+IR(JJST+4)*I2+IR(JJST+7)*I3 IEQ2=IR(JJST+2)*I1+IR(JJST+5)*I2+IR(JJST+8)*I3 IEQ3=IR(JJST+3)*I1+IR(JJST+6)*I2+IR(JJST+9)*I3 C DO 50 K=1,NCENTR DO 30 L=1,3 INDX=JMOD(IEQUIV(L)+ICENTR(L,K)-JTST(L) +ILARG(L),ICELL(L)) C C...CHECK TO SEE IF THE DIFFERENCE (INDX) IS ALMOST A WHOLE CELL TRANSLATION C IF(INDX.GT.NTOL4)INDX=ICELL(L)-INDX 30 IF(INDX.GT.NTOL4)GO TO 50 C C..THESE ARE THE SAME C ISAME=1 RETURN C 50 CONTINUE 100 JJST=JJST+9 C C..DIFFERENT C RETURN END SUBROUTINE SAMER(I1,I2,I3,J1,J2,J3,ISAME) C C....RETURNS ISAME=1 IF (I1,I2,I3) AND (J1,J2,J3) ARE EQUIVALENT POSITIONS C IN REAL CELL WITHIN TOLERANCES NTOL4 C C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C..LOCAL VARIABLES C DIMENSION JTST(3),IEQUIV(3),IR(216),IT(72) EQUIVALENCE (IEQ1,IEQUIV(1)),(IEQ2,IEQUIV(2)),(IEQ3,IEQUIV(3)), 1 (IR(1),IROT(1)),(IT(1),ITRANS(1)) C JTST(1)=J1 JTST(2)=J2 JTST(3)=J3 C ISAME=0 C JST=0 JJST=0 DO 100 J=1,NEQUIV IEQ1=IT(JST+1)+IR(JJST+1)*I1+IR(JJST+4)*I2+IR(JJST+7)*I3 IEQ2=IT(JST+2)+IR(JJST+2)*I1+IR(JJST+5)*I2+IR(JJST+8)*I3 IEQ3=IT(JST+3)+IR(JJST+3)*I1+IR(JJST+6)*I2+IR(JJST+9)*I3 C DO 50 K=1,NCENTR DO 30 L=1,3 INDX=JMOD(IEQUIV(L)+ICENTR(L,K)-JTST(L) +ILARG(L),ICELL(L)) C C...CHECK TO SEE IF THEY DIFFER BY CELL TRANSLATION C IF(INDX.GT.NTOL4)INDX=ICELL(L)-INDX 30 IF(INDX.GT.NTOL4)GO TO 50 C C..THESE ARE THE SAME C ISAME=1 RETURN C 50 CONTINUE JST=JST+3 100 JJST=JJST+9 C C..DIFFERENT C RETURN END SUBROUTINE SAMEH(I1,I2,I3,J1,J2,J3,ISAME) C C....RETURNS ISAME=1 IF (I1,I2,I3) AND (J1,J2,J3) SHARE ALL HARKER VECTORS C WITHIN TOLERANCE NTOL4. ISAME=0 IF THERE ARE NO HARKER VECTORS. C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C..LOCAL VARIABLES C DIMENSION ITST(3),JTST(3),IEQUIV(3),JEQUIV(3) C ISAME=0 IF(NHARK.EQ.0)RETURN C ITST(1)=I1 ITST(2)=I2 ITST(3)=I3 JTST(1)=J1 JTST(2)=J2 JTST(3)=J3 C ISAME=1 C DO 100 J=1,NHARK DO 9 L=1,3 INDX=0 DO 8 LL=1,3 8 INDX=INDX+IHARKR(L,LL,J)*ITST(LL) 9 IEQUIV(L)=INDX+IHARKT(L,J) C C...IS THIS HARKER VECTOR EQUIVALENT TO ONE OF THOSE FOR JTST? C DO 50 K=1,NHARK DO 11 L=1,3 INDX=0 DO 10 LL=1,3 10 INDX=INDX+IHARKR(L,LL,K)*JTST(LL) 11 JEQUIV(L)=INDX+IHARKT(L,K) C CALL SAMEP(IEQUIV(1),IEQUIV(2),IEQUIV(3), 1 JEQUIV(1),JEQUIV(2),JEQUIV(3),IFLAG) C 50 IF(IFLAG.EQ.1)GO TO 100 C C...THIS HARKER VECTOR FOR ITST IS NOT THE SAME AS ANY FOR JTST C ISAME=0 RETURN C 100 CONTINUE RETURN END SUBROUTINE MAXIM C C...FUNCTION: ADJUST POINTS (IA,JA,KA) AND (IB,JB,KB) SO THAT C...THE MINIMUM OF THEIR SELF AND CROSS VECTORS IS AT A MAXIMUM. C C C...DO NOT SHIFT BY MORE THAN NTOL4 C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C...LOCAL VARIABLES C DIMENSION IIN(3,2),IBEST(3,2),ISAVE(3,2),ITST(3,2) C DO 5000 II=1,NPEAK C IA=IPXYZ(1,II) JA=IPXYZ(2,II) KA=IPXYZ(3,II) IB=IP0(1,II) JB=IP0(2,II) KB=IP0(3,II) C ASTART=1.E+30 CALL HARMIN(IA,JA,KA,RHO) ASTART=AMIN1(ASTART,RHO) CALL HARMIN(IB,JB,KB,RHO) ASTART=AMIN1(ASTART,RHO) CALL CROMIN(IA,JA,KA,IB,JB,KB,RHO) ASTART=AMIN1(ASTART,RHO) IIN(1,1)=IA IIN(2,1)=JA IIN(3,1)=KA IIN(1,2)=IB IIN(2,2)=JB IIN(3,2)=KB C DO 1 I=1,2 DO 1 L=1,3 ISAVE(L,I)=0 1 IBEST(L,I)=0 C ID1=1-IHOLD(1) ID2=1-IHOLD(2) ID3=1-IHOLD(3) C C...SHIFT EACH POINT FIVE TIMES C AMAX=ASTART C DO 1000 ITRY=1,5 DO 500 IWHICH=1,2 C DO 300 I1=-ID1,ID1 DO 300 I2=-ID2,ID2 DO 300 I3=-ID3,ID3 DO 5 I=1,2 DO 5 L=1,3 5 ITST(L,I)=IBEST(L,I)+IIN(L,I) C ITST(1,IWHICH)=ITST(1,IWHICH)+I1 ITST(2,IWHICH)=ITST(2,IWHICH)+I2 ITST(3,IWHICH)=ITST(3,IWHICH)+I3 C A=1.E+30 CALL HARMIN(ITST(1,1),ITST(2,1),ITST(3,1),RHO) A=AMIN1(A,RHO) IF(A.LE.AMAX)GO TO 300 CALL HARMIN(ITST(1,2),ITST(2,2),ITST(3,2),RHO) A=AMIN1(A,RHO) IF(A.LE.AMAX)GO TO 300 CALL CROMIN(ITST(1,1),ITST(2,1),ITST(3,1), 1 ITST(1,2),ITST(2,2),ITST(3,2),RHO) A=AMIN1(A,RHO) C IF(A.LE.AMAX)GO TO 300 C AMAX=A DO 60 I=1,2 DO 60 L=1,3 60 ISAVE(L,I)=ITST(L,I)-IIN(L,I) C 300 CONTINUE DO 310 I=1,2 DO 310 L=1,3 310 IBEST(L,I)=JISIGN(JMIN0(IABS(ISAVE(L,I)),NTOL4),ISAVE(L,I)) 500 CONTINUE 1000 CONTINUE C IA=IA+IBEST(1,1) JA=JA+IBEST(2,1) KA=KA+IBEST(3,1) IB=IB+IBEST(1,2) JB=JB+IBEST(2,2) KB=KB+IBEST(3,2) C A=1.E+30 CALL HARMIN(IA,JA,KA,RHO) A=AMIN1(A,RHO) CALL HARMIN(IB,JB,KB,RHO) A=AMIN1(A,RHO) CALL CROMIN(IA,JA,KA,IB,JB,KB,RHO) A=AMIN1(A,RHO) C C IPXYZ(1,II)=IA IPXYZ(2,II)=JA IPXYZ(3,II)=KA IP0(1,II)=IB IP0(2,II)=JB IP0(3,II)=KB C PEAK(II)=A 5000 CONTINUE C RETURN END FUNCTION PROB(M,N,RATIO) COMMON/TABL/TABLE(102),TABLE1(102) C C..RETURNS PROBABILITY THAT, IN N TRIES, NO SET OF M MEASUREMENTS C WILL ALL HAVE MEAS/SIGMA > RATIO C C...RETURNS PROB=0.0 IF RATIO IS L.E. 0.0 (EVEN THOUGH THIS MAY NOT C BE CORRECT ANSWER.) C INEG=0 IF(RATIO.GE.0.0)GO TO 1 RATIO=-RATIO INEG=1 C 1 PROB=0.0 AM=M AN=N C C...GET PROB THAT 1 MEASUREMENT WILL BE > RATIO * SIGMA C P=RATIO*100./3. IF(P.GT.100)P=100. IF(P.LT.0)P=0. IP=P ADEL=P-IP R1=TABLE1(IP+1) R2=TABLE1(IP+2) P=R1+ ADEL*(R2-R1) C C...CHECK FOR RATIO < 0 C IF(INEG.NE.0)P=1.0-P C C...GET PROB THAT NO SET OF M MEASUREMENTS WILL YIELD SIG/NOISE > RATIO C IN N TRIES. C C IF(P.GT.1.0)P=1.0 IF(P.LT.1.E-30)P=1.E-30 P=AM*ALOG10(P) IF(P.LT.-30.)P=-30. P=1.-10**P IF(P.LT.1.E-30)P=1.E-30 P=AN*ALOG10(P) IF(P.LT.-30.)P=-30. PROB=10**P C C PROB= (1.-P**AM)**AN C RETURN END FUNCTION CUT(M,N,SIGNIF) C C...RETURNS RATIO OF SIGNAL TO NOISE (CUT) SUCH THAT THERE IS A PROBABILITY C OF SIGNIF THAT GIVEN N INDEPENDENT TRIALS, NO SET OF M MEASUREMENTS C OF SIGNAL/NOISE WILL ALL BE GREATER THAN CUT. C REAL*8 PP,X,A,DEL,FACT DIMENSION TABLE(102),TABLE1(102) COMMON/TABL/ TABLE,TABLE1 DATA IFIRST /0/ IF(IFIRST.NE.0)GO TO 1000 C IFIRST=1 C C...SET UP ERROR FUNCTION TABLE C PP=0.5D0 TABLE(101)=0. TABLE(102)=0. DEL=3.D-4 FACT=DEL/SQRT(ATAN2(0.,-1.)*2.0) DO 100 I=0,10000 X=I*DEL A=DEXP(-X**2/2.D0) PP=PP-A*FACT IP=INT(200.D0*PP) IF(PP.LT.0.D0)PP=0.D0 IF(JMOD(I,100).EQ.0)TABLE1(I/100+1)=PP 100 TABLE(IP+1)=X TABLE1(1)=0.5 TABLE1(101)=0.0 TABLE1(102)=0.0 C C C...NORMAL CALL C 1000 CUT=-1.E+30 IF(N.LT.1 .OR. SIGNIF.LE.0.0)RETURN CUT=1.E+30 IF(M.LT.1 .OR. SIGNIF.GE.1.0)RETURN C C...USUAL C AN=N AN=1./AN AM=M AM=1./AM P=(1.0-SIGNIF**AN)**AM C C..NOW P HAS THE PROPERTY THAT: (1-P**M)**N = SIGNIF C SO THAT IF THE PROBABILITY OF MEASUREMENT/SIGMA > CUT C IS P, THE PROBABILITY OF NEVER OBSERVING A RANDOM SET C OF M PEAKS ALL GREATER THAN CUT, IN N TRIES, IS SIGNIF. C C...NOTE THAT THE TABLES ONLY HANDLE P < 0.5 C INEG=0 IF(P.LT.0.5)GO TO 1 P=1.0-P INEG=1 1 CONTINUE C C TABLE(200*A+1)=0.5-1/SQRT(TWOPI) * INTEGRAL FROM 0,X OF EXP(-X**2/2) C WHICH IS THE VALUE OF CUT SUCH THAT PROB OF MEAS/SIGMA > CUT = A C P=200.*P IF(P.GT.100.)P=100. IP=P DEL=P-IP IF(IP.GT.100)IP=100 R1=TABLE(IP+1) R2=TABLE(IP+2) CUT=R1+ DEL*(R2-R1) IF(INEG.NE.0)CUT=-CUT RETURN END SUBROUTINE SAVEP(IFLAG,IX,IY,IZ,A,A1,JFLAG,JX,JY,JZ) C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C COMMON /LST/ NP,IXYZ(3,100),P(100), 1 IPREV(100),ILAST,IFIRST,INEXT(100),JXYZ(3,100),PA(100) C DIMENSION IOUT(100) C C..INEXT(0)=IFIRST=POINTER TO TOP PEAK C..IPREV(201)=ILAST=POINTER TO LAST PEAK C C INEXT(I)=POINTER TO NEXT PEAK LOWER THAN PEAK I C..IPREV(I)=POINTER TO PEAK ONE HIGHER THAN PEAK I C IF(IFLAG)1,10,5000 1 NP=0 RETURN C C 10 IF(NP.GT.0)GO TO 1000 NP=1 P(1)=A PA(1)=A1 IXYZ(1,1)=IX IXYZ(2,1)=IY IXYZ(3,1)=IZ IF(JFLAG.EQ.0)GO TO 2 JXYZ(1,1)=JX JXYZ(2,1)=JY JXYZ(3,1)=JZ C 2 IFIRST=1 INEXT(1)=101 ILAST=1 IPREV(1)=0 ITOPFR=2 RETURN C 1000 J=ILAST 1050 IF(A.LE.P(J))GO TO 1200 J=IPREV(J) IF(J.NE.0)GO TO 1050 C. C..HERE J IS POINTER TO SMALLEST ONE NOT SMALLER THAN A C 1200 IF(NP.LT.NPMAX)GO TO 2000 C C...HERE WE MUST DELETE THE LOWEST ONE C C...BUT IF A IS LESS THAN LOWEST ONE, FORGET IT. C IF(J.EQ.ILAST) RETURN C C C ITOPFR=ILAST JPR=IPREV(ILAST) C. C..JPR IS NEXT-TO LAST (NOW IT WILL BE LAST C ILAST=JPR INEXT(JPR)=101 C C..DON'T BOTHER TO CONSIDER ANY MORE POINTS WHICH ARE LOWER THAN C THE LOWEST IN THE LIST IF LIST IS FULL. C CUTOFF=AMAX1(CUTOFF,P(ILAST)) C NP=NP-1 C 2000 NP=NP+1 IXYZ(1,ITOPFR)=IX IXYZ(2,ITOPFR)=IY IXYZ(3,ITOPFR)=IZ IF(JFLAG.EQ.0)GO TO 2002 JXYZ(1,ITOPFR)=JX JXYZ(2,ITOPFR)=JY JXYZ(3,ITOPFR)=JZ C 2002 PA(ITOPFR)=A1 P(ITOPFR)=A C C... NEW POINT GOES BETWEEN J AND JNXT C JNXT=INEXT(J) INEXT(ITOPFR)=JNXT INEXT(J)=ITOPFR IPREV(JNXT)=ITOPFR IPREV(ITOPFR)=J C ITOPFR=ITOPFR+1 RETURN C C...HERE TO DELETE PEAKS THAT ARE TOO CLOSE TOGETHER AND C REORDER PEAKS IN HEIGHT ORDER. C C 5000 I=IFIRST NPEAK=0 IF(NP.EQ.0)RETURN C 5050 NPEAK=NPEAK+1 PEAKA(NPEAK)=PA(I) PEAK(NPEAK)=P(I) DO 5051 L=1,3 IP0(L,NPEAK)=JXYZ(L,I) 5051 IPXYZ(L,NPEAK)=IXYZ(L,I) 5070 IF(I.EQ.ILAST)GO TO 6000 I=INEXT(I) GO TO 5050 C 6000 IF(NPEAK.LE.1)RETURN C IF(IFLAG.EQ.2)RETURN C DO 6100 I=NPEAK,1,-1 IOUT(I)=0 DO 6055 J=I-1,1,-1 C DO 6055 K=1,NCENTR DO 6053 L=1,3 INDX=JMOD(IPXYZ(L,J)+ICENTR(L,K)-IPXYZ(L,I)+ILARG(L),ICELL(L)) IF(INDX.GT.NTOL4)INDX=ICELL(L)-INDX 6053 IF(INDX.GT.NTOL4)GO TO 6055 C C...THESE PEAKS ARE THE SAME C GO TO 6070 C 6055 CONTINUE C C... PEAK I IS DIFFERENT THAN ALL PEAKS OF GREATER HEIGHT C GO TO 6100 C C C...PEAK I IS NOT AS HIGH AS ANOTHER PEAK WHICH IS CLOSER THAN NTOL4 C 6070 IOUT(I)=1 C 6100 CONTINUE C C...DELETE PEAKS WHICH HAVE IOUT=1 C NP=0 DO 6200 I=1,NPEAK IF(IOUT(I).NE.0)GO TO 6200 NP=NP+1 PEAKA(NP)=PEAKA(I) PEAK(NP)=PEAK(I) DO 6151 L=1,3 IP0(L,NP)=IP0(L,I) 6151 IPXYZ(L,NP)=IPXYZ(L,I) C C IF(NP.EQ.100)GO TO 6201 6200 CONTINUE 6201 NPEAK=NP RETURN END SUBROUTINE INSIDE(IX,IY,IZ) C C C..FUNCTION: MAP THE POINT (IX,IY,IZ) ONTO A POINT EQUIVALENT BY SPACE-GROUP C SYMMETRY WHICH IS INSIDE SEARCH REGION, IF POSSIBLE. C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C DIMENSION ITST(3),JTST(3),IEQUIV(3),LIMAP(2,3) EQUIVALENCE(LIMAP(1),NXS) ITST(1)=IX ITST(2)=IY ITST(3)=IZ C DO 4940 J=1,NEQUIV DO 4920 L=1,3 INDX=0 DO 4910 LL=1,3 4910 INDX=INDX+IROT(L,LL,J)*ITST(LL) 4920 JTST(L)=INDX+ITRANS(L,J) C DO 4940 K=1,NCENTR DO 4930 L=1,3 INDX=JMOD(JTST(L)+ICENTR(L,K)+ILARG(L),ICELL(L)) IF(INDX.LT.LIMAP(1,L).OR.INDX.GT.LIMAP(2,L))GO TO 4940 4930 IEQUIV(L)=INDX C C ALL DONE IX=IEQUIV(1) IY=IEQUIV(2) IZ=IEQUIV(3) RETURN 4940 CONTINUE C C..IF HERE, NOT ASYMMETRIC UNIT ANYHOW C RETURN END SUBROUTINE HARMIN(IX,IY,IZ,RHO) C C...FUNCTION: RETURNS MINIMUM OF PATTERSON FUNCTION AT THE (NHARK) HARKER C VECTORS CORRESPONDING TO (IX,IY,IZ). C C IF RHO IS LESS THAN OR EQUAL TO CUTOFF, RHO = 0.0 C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C..LOCAL VARIABLES C DIMENSION IR(216),IT(72) EQUIVALENCE (IR(1),IHARKR(1)),(IT(1),IHARKT(1)) C C RHO=1.E+30 IF(NHARK.LE.0)RETURN C MST=0 MMST=0 DO 100 M=1,NHARK C IP=IT(MST+1)+IR(MMST+1)*IX + IR(MMST+4)*IY + IR(MMST+7)*IZ JP=IT(MST+2)+IR(MMST+2)*IX + IR(MMST+5)*IY + IR(MMST+8)*IZ KP=IT(MST+3)+IR(MMST+3)*IX + IR(MMST+6)*IY + IR(MMST+9)*IZ C CALL PATT(IP,JP,KP,A) C RHO=AMIN1(RHO,A) IF(RHO.LE.CUTOFF)GO TO 200 MMST=MMST+9 100 MST=MST+3 RETURN 200 RHO=-1.E+30 RETURN END SUBROUTINE CROMIN(I1,I2,I3,J1,J2,J3,RHO) C C FUNCTION: RETURN MINIMUM OF VALUES OF PATTERSON FUNCTION AT CROSS-VECTORS C DUE TO (I1,I2,I3) (AND SYMMETRY-RELATED POINTS) C AND DUE TO (J1,J2,J3) (AND SYMMETRY-RELATED POINTS) C C...IGNORES CENTERING, WHICH HAS NO EFFECT ANYHOW C C IF RHO IS LESS THAN OR EQUAL TO CUTOFF, RHO=0.0 C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C C...LOCAL VARIABLES C C DIMENSION IR(216),IT(72) EQUIVALENCE (IR(1),IROT(1)),(IT(1),ITRANS(1)) C RHO=1.E+30 C IST=0 IIST=0 DO 1000 I=1,NEQUIV IP=IT(IST+1)+IR(IIST+1)*I1+IR(IIST+4)*I2+IR(IIST+7)*I3-J1 JP=IT(IST+2)+IR(IIST+2)*I1+IR(IIST+5)*I2+IR(IIST+8)*I3-J2 KP=IT(IST+3)+IR(IIST+3)*I1+IR(IIST+6)*I2+IR(IIST+9)*I3-J3 C CALL PATT(IP,JP,KP,A) C RHO=AMIN1(RHO,A) IF(RHO.LE.CUTOFF)GO TO 2000 IIST=IIST+9 1000 IST=IST+3 RETURN 2000 RHO=-1.E+30 C RETURN END SUBROUTINE SRTSIG(NSRCH,NSTART,SIGN,IFLAG) C C...RESORTS PEAKS BASED ON PROBABILITY THAT THEY OCCURED BY CHANCE C C...IFLAG IS ROUTINE CALLING. NSTART=1 IF ONLY ORIGIN IS GUARANTEED TO BE C THERE, 2 IF CALL IS FROM DOUBLE (CROSS-VECTOR GUARANTEED) C C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C JFLAG=0 IF(IFLAG.EQ.2)JFLAG=1 C C..FIRST MOVE ALL DATA OVER TO ARRAY IPXYZ1 C IF(NPEAK.EQ.0)RETURN DO 1 I=1,NPEAK DO 1 L=1,3 IP1(L,I)=IP0(L,I) 1 IPXYZ1(L,I)=IPXYZ(L,I) NPEAK1=NPEAK C C..NOW RESORT C C..SET UP LIST FOR PEAKS C CALL SAVEP(-1) C C..INITIALIZE SIGNIFICANCE ROUTINE C (NOTE: NEVER CALL IT WITH TEST SOLUTIONS IN ISOLN,ONLY REAL ONES. C CALL ISIGNF(0,0,-1) C C NPEAK=0 C DO 100 I=1,NPEAK1 C C...PUT VALUES OF THE TEST POSITION IN ARRAY IMIN,JMIN,KMIN C NMIN=1 IMIN(1)=IPXYZ1(1,I) JMIN(1)=IPXYZ1(2,I) KMIN(1)=IPXYZ1(3,I) IF(IFLAG.NE.2)GO TO 50 NMIN=2 IMIN(1+NEQUIV)=IP1(1,I) JMIN(1+NEQUIV)=IP1(2,I) KMIN(1+NEQUIV)=IP1(3,I) C 50 CALL ISIGNF(NSRCH,NSTART,IFLAG,APROB,SAMIN) IF(APROB.LT.SIGN)GO TO 100 C C..HERE PROBABILITY THAT THIS PEAK IS NOT RANDOM (APROB) IS OK. C C CALL SAVEP(0,IPXYZ1(1,I),IPXYZ1(2,I),IPXYZ1(3,I),SAMIN,1.-APROB, 1 JFLAG,IP1(1,I),IP1(2,I),IP1(3,I)) 100 CONTINUE C C...REWRITE PEAKS NOW IN ARRAY PEAK C CALL SAVEP(1) C NPEAK1=0 RETURN END SUBROUTINE PATT(IXSAVE,IYSAVE,IZSAVE,RHO) C C...FUNCTION: C C USING PATTERSON SYMMETRY, RETURN IN RHO THE VALUE OF PATTERSON FUNCTION C AT POINT IX,IY,IZ C C IF RHO IS LESS THAN OR EQUAL TO CUTOFF, RHO = -1.E+30 C C...IX,IY,IZ MAY HAVE ANY VALUES WITHIN +/- 1000*CELL DIMENSIONS C C...NOTE THAT GRID FOR SEARCH IS EXACTLY TWICE AS FINE AS GRID FOR INPUT C...PATTERSON MAP. ALL VALUES OF IX,IY,IZ WHICH ARE NOT MULTIPLES OF TWO C...REQUIRE INTERPOLATION BETWEEN PATTERSON GRID POINTS. C C...INTERPOLATION USED HERE IS SIMPLE: IF A POINT IS BETWEEN TWO GRID C POINTS, VALUE IS HALF THE SUM; IF A POINT IS IN CENTER OF 4 GRID C POINTS, VALUE IS 1/4 THE SUM AT THE FOUR GRID POINTS; IF POINT IS C AT CENTER OF 8 GRID POINTS, VALUE IS 1/8 THE SUM OF 8 GRID POINTS. C C C...ARRAY IOPER CONTAINS MOST LIKELY OPERATION TO MAP POINT CONTAINED IN C EACH AREA OF UNIT CELL ONTO PATTERSON ASYMMETRIC UNIT. C C COMMON BLOCKS FOR PROGRAM "HASSP" C COMMON /CNTL/ ITYPE,NPMAX,NSFMAX,NBOX,DISCRM,NOSPEC,NFREE, 1 SIGMA,ALPHA,AMNSYM,SPAT,SSIN,SDUB,STRP,SSFT,NSIGNF,NCRMAX,SHI C COMMON /FILS/ MEPFIL(40),NQMEP,PATFIL(40),NQPAT, 1 NCRFIL(40),NQNCR LOGICAL*1 MEPFIL,PATFIL,MAPFIL,NCRFIL C COMMON /MAPS/ NX1,NY1,NZ1,NPATXE,NPATYE,NPATZE,PATTER(1800000) COMMON /MAP1/ NXS,NXE,NYS,NYE,NZS,NZE, 1 NX,NY,NZ,INCR(13,1024), 1 ISHIFX,ISHIFY,ISHIFZ,IOPER(1024),IDIV(3),NDIV1,NDIV2,NDIV3, 1 ICELL(3),IPCELL(3),ILARG(3),NTOL2,NTOL4,AMAP(40000) DIMENSION NMAP(3),LIMITS(3) EQUIVALENCE (LIMITS(1),NPATXE),(NMAP(1),NX) C COMMON /PEKS/ CUTOFF,IPXYZ(3,100),PEAK(100),PEAKA(100),NPEAK, 1 IPXYZ1(3,100),PEAK1(100),NPEAK1,IP0(3,100),IP1(3,100),IP2(3,100), 1 PEAK1A(100),PEAK2A(100),IPXYZ2(3,100),PEAK2(100),ISYMM(100),NPEAK2, 1 ICROSS(3,100),PCROSS(100),NCROSS,ICRMAX, 1 ISOLN(3,100),WSOLN(100),NSOLN,ISING(3,100),NSING C COMMON /SYMM/ IORIG(3,8),NORIG,IHOLD(3),IGEN(3), 1 IROT(3,3,24),ITRANS(3,24),NEQUIV, 1 ICENTR(3,24),NCENTR, 1 IHARKR(3,3,24),IHARKT(3,24),NHARK, 1 IPROT(3,3,48),IPCEN(3,24),NPROT,AROT(3,3,24),ATRAN(3,24),NNCR C COMMON /MINMS/ NMIN,MMIN,IMIN(200),JMIN(200),KMIN(200) C C C...LOCAL VARIABLES C DIMENSION IXYZ(3),IEQUIV(3),ITST(3),IIPROT(216),IICE(72) EQUIVALENCE (ITST(1),IP),(ITST(2),JP),(ITST(3),KP), 1 (IIPROT(1),IPROT(1)),(IICE(1),IPCEN(1)), 1 (IX1,IXYZ(1)),(IY1,IXYZ(2)),(IZ1,IXYZ(3)), 1 (IEQ1,IEQUIV(1)),(IEQ2,IEQUIV(2)),(IEQ3,IEQUIV(3)), 1 (IPC1,IPCELL(1)),(IPC2,IPCELL(2)),(IPC3,IPCELL(3)), 1 (IL1,ILARG(1)),(IL2,ILARG(2)),(IL3,ILARG(3)), 1 (IC1,ICELL(1)),(IC2,ICELL(2)),(IC3,ICELL(3)), 1 (IDIV1,IDIV(1)),(IDIV2,IDIV(2)),(IDIV3,IDIV(3)) C C C..CHECK FOR ORIGIN FIRST C IF(IXSAVE.NE.0 .OR. IYSAVE.NE.0 .OR. 1 IZSAVE.NE.0)GO TO 1 RHO=PATTER(1) RETURN C 1 IX=JMOD(IXSAVE+IL1,IC1) IY=JMOD(IYSAVE+IL2,IC2) IZ=JMOD(IZSAVE+IL3,IC3) C C C C..FIRST TRY OPERATION FROM APPROPRIATE POSITION IN IOPER C C...UNIT CELL IS DIVIDED INTO BOXES IDIV(1-3) GRID UNITS ON A SIDE, C WITH NDIV(1-3) BOXES ALONG CELL EDGES 1-3. NEXT LINE CALCULATES C INDEX OF APPROPRIATE BOX C INDX= 1 + (IX/IDIV1) + NDIV1 * (IY/IDIV2 + NDIV2 * (IZ/IDIV3)) II=IOPER(INDX) K=II/NPROT J=II- K*NPROT + 1 K=K+1 C C...NOW J IS INDEX OF ROTATION, K IS INDEX OF CENTERING OPERATION C C....SPECIAL CASE OF J=1 (IDENTITY) OR J=2 (INVERSE) C IF(J-2)2,3,4 C C..IDENTITY: J=1 C 2 IF(K.EQ.1)GO TO 11 IEQ1=IX IEQ2=IY IEQ3=IZ GO TO 6 C C...INVERSE: J=2. INVERT INTO UNIT CELL AND DO SAME AS IDENTITY. C 3 IX=IC1-IX IF(IX.EQ.IC1)IX=0 IY=IC2-IY IF(IY.EQ.IC2)IY=0 IZ=IC3-IZ IF(IZ.EQ.IC3)IZ=0 GO TO 2 C C...ALL OTHER CASES: J > 2 C 4 JJST=(J-1)*9 IEQ1=IIPROT(JJST+1)*IX+IIPROT(JJST+4)*IY+IIPROT(JJST+7)*IZ IEQ2=IIPROT(JJST+2)*IX+IIPROT(JJST+5)*IY+IIPROT(JJST+8)*IZ IEQ3=IIPROT(JJST+3)*IX+IIPROT(JJST+6)*IY+IIPROT(JJST+9)*IZ C 5 IF(K.EQ.1)GO TO 10 C C...CENTERED HERE. C 6 IX=JMOD(IEQ1+ICENTR(1,K)+IL1,IC1) IY=JMOD(IEQ2+ICENTR(2,K)+IL2,IC2) IZ=JMOD(IEQ3+ICENTR(3,K)+IL3,IC3) GO TO 11 C C..NO CENTERING C 10 IX=JMOD(IEQ1+IL1,IC1) IY=JMOD(IEQ2+IL2,IC2) IZ=JMOD(IEQ3+IL3,IC3) C 11 IX2=IX/2 IDX=IX-2*IX2 IY2=IY/2 IDY=IY-2*IY2 IZ2=IZ/2 IDZ=IZ-2*IZ2 C C...IX2+IDX/2,IY2+IDY/2,IZ2+IDZ/2 ARE CORRECT GRID POSITIONS C IN PATTERSON MAP GRID FOR IX,IY,IZ. C C...NOW IF IDX,IDY,AND IDZ ARE = 0, THEN NO INTERPOLATION IS C NECESSARY. FURTHER, IF IX2,IY2,IZ2 ARE ALL INSIDE PATTERSON C MAP AS INPUT, NO NEED TO DO ANY MORE MAPPING. C IF(IDX.NE.0 .OR. IDY.NE.0 .OR. IDZ.NE.0 .OR. 1 IX2.GT.NPATXE .OR. IY2.GT.NPATYE .OR. IZ2.GT. NPATZE) 1 GO TO 7 C C...THIS IS ALL OK HERE. JUST RETURN VALUE. C RHO=PATTER(1+IX2+NX1*(IY2+NY1*IZ2)) IF(RHO.LE.CUTOFF)RHO=-1.E+30 RETURN C C . WE INTERPOLATE TO GET APPROXIMATE VALUE OF RHO HERE C 7 SUM=0.0 N=0 IF(NCENTR.EQ.1)GO TO 5001 C DO 5000 IOFF=0,IDX IX1=IX2+IOFF IF(IX1.GE.IPC1)IX1=IX1-IPC1 DO 5000 JOFF=0,IDY IY1=IY2+JOFF IF(IY1.GE.IPC2)IY1=IY1-IPC2 DO 5000 KOFF=0,IDZ IZ1=IZ2+KOFF IF(IZ1.GE.IPC3)IZ1=IZ1-IPC3 C C C...GO THROUGH ALL EQUIVALENT POSITIONS, SEE IF IT WITHIN THE LIMITS OF C SUPPLIED PATTERSON MAP. IF SO, RETURN THE VALUE AT THIS POINT. C C...TRY SPECIAL CASE OF ALL OK FIRST: C IF(IX1.GT.NPATXE .OR. IY1.GT.NPATYE .OR. 1 IZ1.GT.NPATZE)GO TO 15 IP=IX1 JP=IY1 KP=IZ1 GO TO 31 C C 15 JST=0 JJST=0 C C...LOOK AT EVERY OTHER ROTATION MATRIX. THE OTHERS ARE INVERSES. C THE FIRST TWO ARE IDENTITY AND INVERSE (WHICH WE ALREADY TESTED). C DO 100 J=1,NPROT,2 C IF(J.NE.1)GO TO 24 IEQ1=IX1 IEQ2=IY1 IEQ3=IZ1 GO TO 25 C 24 IEQ1=IIPROT(JJST+1)*IX1+IIPROT(JJST+4)*IY1+IIPROT(JJST+7)*IZ1 IEQ2=IIPROT(JJST+2)*IX1+IIPROT(JJST+5)*IY1+IIPROT(JJST+8)*IZ1 IEQ3=IIPROT(JJST+3)*IX1+IIPROT(JJST+6)*IY1+IIPROT(JJST+9)*IZ1 C 25 JST=JST+6 JJST=JJST+18 C C...TRY EACH CENTERING AND INVERSE C KST=0 DO 50 K=1,NCENTR C INV=1 IP=JMOD(IEQ1+IICE(KST+1)+IL1,IPC1) IF(IP.LE.NPATXE)GO TO 26 IP=IPC1-IP IF(IP.EQ.IPC1)IP=0 IF(IP.GT.NPATXE)GO TO 50 INV=-1 C C...HERE ONLY INVERSE WORKED C 26 JP=JMOD(INV*(IEQ2+IICE(KST+2))+IL2,IPC2) IF(JP.LE.NPATYE)GO TO 27 IF(INV.EQ.-1)GO TO 50 C C...IF INVERSE IS ALREADY -1 AND THIS DIDN'T WORK, TRY NEXT CENTERING C IP=IPC1-IP IF(IP.EQ.IPC1)IP=0 IF(IP.GT.NPATXE)GO TO 50 JP=IPC2-JP IF(JP.EQ.IPC2)JP=0 IF(JP.GT.NPATYE)GO TO 50 INV=-1 C 27 KP=JMOD(INV*(IEQ3+IICE(KST+3))+IL3,IPC3) IF(KP.LE.NPATZE)GO TO 31 IF(INV.EQ.-1)GO TO 50 IP=IPC1-IP IF(IP.EQ.IPC1)IP=0 IF(IP.GT.NPATXE)GO TO 50 JP=IPC2-JP IF(JP.EQ.IPC2)JP=0 IF(JP.GT.NPATYE)GO TO 50 KP=IPC3-KP IF(KP.EQ.IPC3)KP=0 IF(KP.GT.NPATZE)GO TO 50 C 31 RHO=PATTER( 1+IP+NX1*(JP+NY1*KP) ) C GO TO 4000 C 50 KST=KST+3 C C...KEEP TRYING CENTERING C 100 CONTINUE C C..KEEP TRYING ROTATIONS C STOP 'INPUT PATTERSON MAP DOES NOT HAVE ASYMMETRIC UNIT OF MAP' C 4000 N=N+1 5000 SUM=SUM+RHO RHO=SUM/FLOAT(N) IF(RHO.LE.CUTOFF)RHO=-1.E+30 RETURN C C C...HERE FOR NON-CENTERED CELLS C 5001 SUM=0.0 N=0 DO 7000 IOFF=0,IDX IX1=IX2+IOFF IF(IX1.EQ.IPC1)IX1=0 DO 7000 JOFF=0,IDY IY1=IY2+JOFF IF(IY1.EQ.IPC2)IY1=0 DO 7000 KOFF=0,IDZ IZ1=IZ2+KOFF IF(IZ1.EQ.IPC3)IZ1=0 C C...CHECK TO SEE IF THIS IS ALREADY OK. C IF(IX1.GT.NPATXE .OR. IY1.GT.NPATYE .OR. IZ1.GT.NPATZE)GO TO 5007 IEQ1=IX1 IEQ2=IY1 IEQ3=IZ1 GO TO 5031 C 5007 IEQ1=IPC1-IX1 IF(IEQ1.EQ.IPC1)IEQ1=0 IF(IEQ1.GT.NPATXE)GO TO 5008 IEQ2=IPC2-IY1 IF(IEQ2.EQ.IPC2)IEQ2=0 IF(IEQ2.GT.NPATYE)GO TO 5008 IEQ3=IPC3-IZ1 IF(IEQ3.EQ.IPC3)IEQ3=0 IF(IEQ3.LE.NPATZE)GO TO 5031 C C...GO THROUGH ALL EQUIVALENT POSITIONS, SEE IF IT WITHIN THE LIMITS OF C SUPPLIED PATTERSON MAP. IF SO, RETURN THE VALUE AT THIS POINT. 5008 IF(NPROT.LT.3)GO TO 5050 JST=0 JJST=0 DO 5050 J=3,NPROT,2 C INV=1 JST=JST+6 JJST=JJST+18 C IEQ1=JMOD(IIPROT(JJST+1)*IX1+IIPROT(JJST+4)*IY1+IIPROT(JJST+7)*IZ1+ 2 IL1,IPC1) C IF(IEQ1.LE.NPATXE)GO TO 5009 C IEQ1=IPC1-IEQ1 IF(IEQ1.EQ.IPC1)IEQ1=0 IF(IEQ1.GT.NPATXE)GO TO 5050 INV=-1 C 5009 IEQ2=JMOD(INV*(IIPROT(JJST+2)*IX1+IIPROT(JJST+5)*IY1 1 +IIPROT(JJST+8)*IZ1) + 2 IL2,IPC2) C IF(IEQ2.LE.NPATYE)GO TO 5010 C IF(INV.EQ.-1)GO TO 5050 IEQ1=IPC1-IEQ1 IF(IEQ1.EQ.IPC1)IEQ1=0 IF(IEQ1.GT.NPATXE)GO TO 5050 IEQ2=IPC2-IEQ2 IF(IEQ2.EQ.IPC2)IEQ2=0 IF(IEQ2.GT.NPATYE)GO TO 5050 INV=-1 C 5010 IEQ3=JMOD(INV*(IIPROT(JJST+3)*IX1+IIPROT(JJST+6)*IY1+ 1 IIPROT(JJST+9)*IZ1) + 2 IL3,IPC3) C IF(IEQ3.LE.NPATZE)GO TO 5031 C IF(INV.EQ.-1)GO TO 5050 IEQ1=IPC1-IEQ1 IF(IEQ1.EQ.IPC1)IEQ1=0 IF(IEQ1.GT.NPATXE)GO TO 5050 IEQ2=IPC2-IEQ2 IF(IEQ2.EQ.IPC2)IEQ2=0 IF(IEQ2.GT.NPATYE)GO TO 5050 IEQ3=IPC3-IEQ3 IF(IEQ3.EQ.IPC3)IEQ3=0 IF(IEQ3.GT.NPATZE)GO TO 5050 C C C...THIS IS IT. ALL INDICES ARE IN RANGE C 5031 RHO=PATTER( 1 + IEQ1 + NX1*(IEQ2+NY1*IEQ3) ) C GO TO 6000 C 5050 CONTINUE C C STOP 'INPUT PATTERSON MAP DOES NOT HAVE ASYMMETRIC UNIT OF MAP' C 6000 N=N+1 7000 SUM=SUM+RHO RHO=SUM/FLOAT(N) IF(RHO.LE.CUTOFF)RHO=-1.E+30 RETURN END