CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C SAPI C A direct-method program to locate heavy atom positions. C Modified by Q. Hao (1,2) C Original Authors: Y.X.Gu, C.D.Zheng, J.X.Yao, J.Z.Qian & H.F.Fan (2) C Email: qh22@cornell.edu or fan@aphy.iphy.ac.cn C (1) Cornell University, USA C (2) Institute of Physics, Chinese Academy of Sciences, Beijing,China CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC PROGRAM SAPI CHARACTER*132 AA CHARACTER*8 CDATE,CTIME C GET INITIAL TIME CALL CCPDAT(CDATE) CALL UTIME(CTIME) WRITE(6,910) CDATE,CTIME 910 FORMAT(53X,A8,3X,A8) CALL CCPFYP c call ccprcs (6, 'SAPI', '$Date: 2001/02/12 09:25:49 $') WRITE (6,100) CALL CCPDPN(10,'KEYWORD.TM','SCRATCH','F',80,0) c OPEN(10,FILE='KEYWORD.TM',FORM='FORMATTED',STATUS='UNKNOWN') 1 READ (5,10,END=2)AA WRITE (10,10)AA GOTO 1 2 CONTINUE CALL PREPAR CALL PHASE CALL EXFFT CALL SEARCH4 10 FORMAT(A132) 100 FORMAT(///,' ****** SAPI ******',/ & ' Version 1.1, 10/10/2001',// & 'A direct-method program to locate heavy atom positions.'// & 'Authors: YX Gu, JX Yao, CD Zheng, HF Fan (1) & Q Hao(2)',/ & '(1) Institute of Physics, Chinese Academy of Sciences',/ & '(2) Cornell University, USA.',/ & 'Email: qh22@cornell.edu or fan@aphy.iphy.ac.cn'//) CALL CCPERR(0,'Normal termination') END ************************************************************************ * * * PPPPPPPP RRRRRRRR EEEEEEEEE PPPPPPPP A RRRRRRRR * * PPPPPPPPP RRRRRRRRR EEEEEEEEE PPPPPPPPP AAA RRRRRRRRR * * PP PP RR RR EE PP PP AA AA RR RR * * PP PP RR RR EE PP PP AA AA RR RR * * PPPPPPPPP RRRRRRRRR EEEEEEE PPPPPPPPP AA AA RRRRRRRRR * * PPPPPPPP RRRRRRRR EEEEEEE PPPPPPPP AA AA RRRRRRRR * * PP RR RR EE PP AAAAAAAAA RR RR * * PP RR RR EE PP AAAAAAAAA RR RR * * PP RR RR EEEEEEEEE PP AA AA RR RR * * PP RR RR EEEEEEEEE PP AA AA RR RR * * * * PROGRAM FOR PRELIMINARY PROCESSING OF THE INPUT DATA * * ** AN EXTENSIVE MODIFICATION OF THE PROGRAM 'NORMAL' OF MULTAN-80 ** * * PC VERSION 1998 * ************************************************************************ SUBROUTINE PREPAR C INCLUDE 'FLIB.FI' COMMON/ATMFACTOR/AL(8),AS(8),BL(8),BS(8),CL(8),CS(8),DL(8),DS(8), 1 EL(8),NW(8),NO(8),NK,NAT,F(9) COMMON/ATMGROUP/NINF(10),NAG(10),X(5000),Y(5000),Z(5000),NZ(5000), 1 Q(5000),U11(5000),U22(5000),U33(5000),U23(5000), 2 U13(5000),U12(5000) COMMON/REFLXIN/LH(600),LK(600),LL(600),FO(600),ID(600),RHO(600), 1 SIG(600),XKP(600) COMMON/REFLXOUT/IX(30000),EX(30000),FX(30000),SCMK(30000) COMMON/RESCALING/ISC,IBGR,MG,MIG(8),SCL,BT(9),SC(9),IP(8,3,5), 1 SCAL(8),RSTT COMMON/SCATFACTOR/GIS(142),GIW(142),NGP,NDIFF,ISOL,X0(3) COMMON/SINETABLE/SINT(450) COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT, 1 IAVE,EXTI COMMON/STATISTICS/VST(10,5),NST(5),ZT(25,5),EE(10),MULT,IND,NZR, 1 TMUL C UNITS FOR INPUT/OUTPUT, TITLE, FLAGS COMMON/UNIT1/ ITLE(80),LIST,PI,KCURV,IPAT,IAPA,MOV,MFP,NAU COMMON/WILSON/FLGW(30,9),FLGD(30,9),AVR(30,9),DCV(50,9),SLOPE(9), 1 FLGK(9),DEL(9),KS(9),EW(600),ED(600),EDP(600) COMMON/XXX/P(6),CX(9),NREF,NB,RHOMAX,MM,EMAX,EN,MZ,ER,ISIM,RHOCUT, 1 RHOMIN,RHOLOW,ENG(8),ERG(8),KNOWN,IPATH,VOLUME CHARACTER NGS(26),KX(10),ITERM(4),NTLE(80),ITLE,KSP,KP,KM,KEQ,KC DATA KX/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/ DATA KSP/1H /,KP/1H+/,KM/1H-/,KEQ/1H=/,KSC/1H;/ DATA ITERM/1HH,1HK,1HL,1HN/ C SET UP INITIAL VALUES, READ PROGRAM PARAMETERS PI=4.0*ATAN(1.0) NREF=0 RHOMAX=0.0 RHOMIN=1.0 DTOR=PI/180.0 C SET UP SIN/COS TABLE DO 50 I=1,450 SINT(I)=SIN(DTOR*FLOAT(I-1)) 50 CONTINUE CALL CCPDPN(2,'FCOEF.TM','SCRATCH','U',80,0) CALL CCPDPN(8,'SCRA8.TM','SCRATCH','U',80,0) c OPEN(2,FILE='FCOEF.TM',FORM='UNFORMATTED',STATUS='UNKNOWN') C OPEN(5,FILE='KEYWORD.TM',FORM='FORMATTED',STATUS='UNKNOWN') C OPEN(6,FILE='PREPARE.OUT',FORM='FORMATTED',STATUS='UNKNOWN') c OPEN(8,FILE='SCRA8.TM',FORM='UNFORMATTED',STATUS='UNKNOWN') REWIND 10 C READ TITLE READ (10,100) NTLE 100 FORMAT(80A1) IL=80 IR=80 DO 103 I=1,80 IF (NTLE(I).NE.KSP.AND.IL.EQ.80) IL=I-1 IF (NTLE(80-I+1).NE.KSP.AND.IR.EQ.80) IR=I-1 103 CONTINUE IM=(IL+IR)/2 DO 105 I=1,80 IF (I.LE.IM) ITLE(I)=KSP IF (I.GT.IM) ITLE(I)=NTLE(IL+I-IM) 105 CONTINUE c-qh IF (IERR.EQ.1) GO TO 900 CALL INPUT_P(JUMP,NON,MISS,KMARK,NTOTAL,BTT) IF(NON.NE.1) GO TO 300 STOP' --- PREPARE COMPLETED ---' C READ REFLECTION DATA FROM DATA FILE 300 CALL DATAIN(MH,MK,ML) ANAT=FLOAT(NAT)/(PTS*FLOAT((ICENT+1)*NSYM)) WRITE (6,370) ANAT 370 FORMAT(/1X,36HNUMBER OF ATOMS IN ASYMMETRIC UNIT =,F8.2) NASU=INT(ANAT+0.5) C CHECK IF WEIGHTED OR DIFFERENCE FOURIER IS REQUIRED NDIFF=0 DO 400 I=1,NGP IF (NINF(I).EQ.6.OR.NINF(I).EQ.7) GO TO 410 400 CONTINUE IF (MM.GT.0) WRITE (6,405) MM,MZ 405 FORMAT(1X,21HOUTPUT FOR PHASE - ,I5,13H LARGEST E'S,3X, 1 'AND',I5,14H SMALLEST E'S) GO TO 420 410 NDIFF=1 REWIND 8 WRITE (2) NDIFF WRITE (2) ITLE,ICENT,LATT,NSYM,((TS(I,J),(IS(K,I,J),K=1,3), 1 I=1,3),J=1,NSYM),(NDIFF,I=1,3),(CX(I),I=1,6),NASU,RHOCUT 2 ,RHOLOW EN=0.0 ER=0.0 DO 415 I=1,8 ENG(I)=0.0 ERG(I)=0.0 415 CONTINUE SC(1)=SQRT(SCAL(1)) IF (SC(1).LT.0.01) SC(1)=1.0 420 MKR=0 IF (NDIFF.EQ.1) CALL RFAC(ICENT,NINF) IF (NDIFF.EQ.1) GO TO 900 C CALCULATE NUMBER OF REFLEXIONS TO PASS TO PHASE IF (MM.GT.0) GO TO 422 MN = INT(16.0*ANAT+150.5) IF (ICENT.EQ.1) MN = MN + 50 IF (NSYM.EQ.1) MN = MN + 50 MM = MIN0(MN,15000) IF (MN.LE.500) MM=MN+MIN0(500-MN,100)/2 MM=MAX0(MM,200) C 422 MM=MIN0(MM,NREF-100) MM=MIN0(MM,NREF-100) 422 IF (NREF.LE.500.AND.EN.EQ.1.2) EN=0.9 IF (NREF.LE.300.AND.MZ.EQ.100) MZ=50 IF (ISC.NE.2) GO TO 635 C SPECIAL RESCALING MKR=MKR+1 432 WRITE (6,500) MG 500 FORMAT(/1X,13X,41HREFLECTIONS ARE RESCALED ACCORDING TO & ,I3,13H INDEX GROUPS) IF (MKR.EQ.1) WRITE (6,510) 510 FORMAT(28X,23H(SPECIFIED BY THE USER)) C PRINT OUT THE INDEX RELATIONSHIPS DO 591 MI=1,MG MJ=0 DO 530 J=1,3 DO 520 K=1,3 IF (IP(MI,J,K).EQ.0) GO TO 520 MJ=MJ+1 GO TO 530 520 CONTINUE 530 CONTINUE IF (MJ.EQ.0) GO TO 591 DO 580 J=1,MJ DO 554 II=1,26 NGS(II)=KSP 554 CONTINUE I=0 II=2 DO 570 K=1,5 IF (IP(MI,J,K).NE.0) GO TO 555 IF (K.NE.5) GO TO 560 IF (IP(MI,J,4).NE.0) GO TO 560 555 KK=IABS(IP(MI,J,K)) IF (I.EQ.0) GO TO 556 IF (IP(MI,J,K).GT.0) NGS(II)=KP 556 IF (IP(MI,J,K).LT.0) NGS(II)=KM I=1 IF (NGS(II).NE.KSP) II=II+2 IF (KK.EQ.1.AND.K.NE.5) GO TO 558 IF (KK.LT.10) GOTO 557 NGS(II)=KX(INT(KK/10)+1) II=II+1 KK=MOD(KK,10) 557 NGS(II)=KX(KK+1) II=II+2 558 IF (K.EQ.5) GO TO 560 NGS(II)=ITERM(K) II=II+2 560 IF (K.NE.3) GO TO 570 NGS(II)=KEQ I=0 II=II+2 570 CONTINUE 573 FORMAT(/25X,5HGROUP,I3,5X,26A1) 574 FORMAT(38X,26A1) IF (J.EQ.1) WRITE (6,573) MI,NGS IF (J.NE.1) WRITE (6,574) NGS 580 CONTINUE 591 CONTINUE 635 IF (NB.EQ.0) NB=8.0*ALOG10(0.05*FLOAT(MAX0(NREF,100))+0.5) C MAXIMUM OF 30 POINTS ON WILSON PLOT IF (NB.GT.30) NB=30 RHOCUT=AMIN1(RHOCUT,RHOMAX) RHOLOW=AMAX1(RHOLOW,RHOMIN) ANGMAX=0.5*SQRT(1.0/RHOMAX) ANGLHI=0.5*SQRT(1.0/RHOCUT) ANGLOW=0.5*SQRT(1.0/RHOLOW) WRITE (6,640) NREF,RHOMAX,ANGMAX,ANGLOW,ANGLHI,NB 640 FORMAT(/1X,'TOTAL NUMBER OF REFLEXION (IN DATA-FILE) =',I6/ 1 1X,37HMAXIMUM (SIN(THETA)/LAMBDA)**2 =,F9.4,' (',F5.2, 2 ') ANGSTROM'/1X,'LIMIT OF RESOLUTION FOR PHASE/EXFFT =', 3 F7.2,' to',F7.2,' ANGSTROM'/ 4 1X,33HNUMBER OF POINTS ON WILSON PLOT =,I3) SC(1)=1.0 IF (JUMP.GE.0) GO TO 650 C OBTAIN SUMS FOR WILSON PLOT AND FIT LEAST SQUARES STRAIGHT LINE CALL WILSONN(MH,MK,ML,MISS,BTT) IF (ISC.EQ.2.OR.NAU.EQ.1) GO TO 645 CALL AUTOGP(LATT,EN) IF (ISC.EQ.2) GO TO 432 C PLOT WILSON AND DEBYE CURVES AND LEAST SQUARES STRAIGHT LINE 645 CALL GRAPH(NGP) 650 DO 655 I=1,8 BT(I)=2.0*BT(I) IF (BT(I).LT.-199.9) BT(I)=BT(1) IF (SCAL(I).LT.0.00001) SCAL(I)=SCAL(1) 655 CONTINUE IF (IPAT.NE.0) GO TO 750 C CALCULATE SCALE FACTORS FOR APPROPRIATE REFLEXION GROUPS CALL RESCA(KSYS,JUMP) IF (NINF(1).EQ.4) NGP=0 C OUTPUT FOR PHASE CALL CCPDPN(1,'PHASDT.TM','SCRATCH','F',80,0) c OPEN(1,FILE='PHASDT.TM',FORM='FORMATTED',STATUS='UNKNOWN') WRITE (1,660) ITLE,(CX(I),I=1,6),NW,NO,ICENT,LATT,NSYM,NGP,NASU 660 FORMAT(80A1/6F10.5/16I5/5I5) WRITE (1,670) ((TS(I,J),(IS(K,I,J),K=1,3),I=1,3),J=1,NSYM) 670 FORMAT(3(F11.8,3I3)) IF (NGP.EQ.0) GO TO 700 NF=0 DO 690 I=1,NGP NS=NF+1 NF=NF+NAG(I) WRITE (1,680) NINF(I),NAG(I),(NZ(J),X(J),Y(J),Z(J),J=NS,NF) 680 FORMAT(2I5/(I5,3F10.6)) 690 CONTINUE C CALCULATE FINAL E'S AND OUTPUT REFLEXION STATISTICS 700 CALL ECAL IF (NGP.LE.0) GO TO 720 NF=0 DO 710 IGP=1,NGP NS=NF+1 NF=NF+NAG(IGP) IF (NINF(IGP).LT.5) GO TO 710 IF (NINF(IGP).EQ.5) CALL RECYC(NS,NF,KMARK) GO TO 720 710 CONTINUE 720 CONTINUE c CLOSE (1) GO TO 900 750 NDIFF=2 REWIND 2 WRITE (2) NDIFF WRITE (2) ITLE,ICENT,LATT,NSYM,((TS(I,J),(IS(K,I,J),K=1,3), 1 I=1,3),J=1,NSYM),(NDIFF,I=1,3),(CX(I),I=1,6),NASU,RHOCUT 2 ,RHOLOW CALL PATT 900 CONTINUE c CLOSE (2) close (8) c CLOSE (8,STATUS='DELETE') C OUTPUT FOR SEARCH REWIND 11 c CALL CCPDPN(11,'SEARCH.TM','UNKNOWN','F',80,0) CALL CCPDPN(38,'SEARKW.TM','SCRATCH','F',80,0) c OPEN(UNIT=11,FILE='SEARCH.TM',FORM='FORMATTED',STATUS='UNKNOWN') c OPEN(UNIT= 8,FILE='SEARKW.TM',FORM='FORMATTED',STATUS='UNKNOWN') DO 950 I=1,NTOTAL READ (11,100) NTLE WRITE (38,100) NTLE 950 CONTINUE CLOSE (11) c CLOSE (38) END C----------------------------------------------------------------------- SUBROUTINE ATMCOEF C CALCULATE SPHERICAL SCATTERING FACTOR COEFFICIENTS C ATOMIC SCATTERING FACTOR COEFFICIENTS FOR 98 ATOM TYPES C F = AL * EXP(-AS * RHO) + BL * EXP(-BS * RHO) C + CL * EXP(-CS * RHO) + DL * EXP(-DS * RHO) + EL C COMMON/ATMFACTOR/AL(8),AS(8),BL(8),BS(8),CL(8),CS(8),DL(8),DS(8), 1 EL(8),NW(8),NO(8),NK,NAT,F(9) DIMENSION ALT(98),AST(98),BLT(98),BST(98),ELT(98),N1(98) DIMENSION CLT(98),CST(98),DLT(98),DST(98) DATA N1/ 8,805,1209,205, 2, 3, 14, 15, 6,1405,1401,1307,112,1909, 1 16, 19, 312,118, 11, 301,1903,2009, 22, 318,1314,605,315,1409, 2 321,2614, 701,705,119,1905,218,1118,1802,1918,25,2618,1402,1315, 3 2003,1821,1808,1604, 107,304,914,1914,1902,2005, 9,2405,319,201, 4 1201,305,1618,1404,1613,1913,521,704,2002,425,815,518,2013,2502, 5 1221,806,2001, 23,1805,1519,918,1620,121,807,2012,1602,209,1615, 6 120,1814,618,1801, 103,2008,1601, 21,1416,1621,113,313, 211,306/ DATA ALT/0.489918,0.873400, 1.128200, 1.591900, 2.054500, 9 2.310000, 12.212600, 3.048500, 3.539200, 3.955300, 9 4.762600, 5.420400, 6.420200, 6.291500, 6.434500, 9 6.905300, 11.460400, 7.484500, 8.218600, 8.626600, 9 9.189000, 9.759500, 10.297100, 10.640600, 11.281900, 9 11.769500, 12.284100, 12.837600, 13.338000, 14.074300, 9 15.235400, 16.081600, 16.672300, 17.000601, 17.178900, 9 17.355499, 17.178400, 17.566299, 17.775999, 17.876499, 9 17.614201, 3.702500, 19.130100, 19.267401, 19.295700, 9 19.331900, 19.280800, 19.221399, 19.162399, 19.188900, 9 19.641800, 19.964399, 20.147200, 20.293301, 20.389200, 9 20.336100, 20.577999, 21.167101, 22.044001, 22.684500, 9 23.340500, 24.004200, 24.627399, 25.070900, 25.897600, 9 26.507000, 26.904900, 27.656300, 28.181900, 28.664101, 9 28.947599, 29.143999, 29.202400, 29.081800, 28.762100, 9 28.189400, 27.304899, 27.005899, 16.881901, 20.680901, 9 27.544600, 31.061701, 33.368900, 34.672600, 35.316299, 9 35.563099, 35.929901, 35.763000, 35.659698, 35.564499, 9 35.884701, 36.022800, 36.187401, 36.525398, 36.670601, 9 36.648800, 36.788101, 36.918499/ DATA AST/20.659300,9.103700,3.954600, 43.642700, 23.218500, 9 20.843901, 0.005700, 13.277100, 10.282500, 8.404200, 9 3.285000, 2.827500, 3.038700, 2.438600, 1.906700, 9 1.467900, 0.010400, 0.907200, 12.794900, 10.442100, 9 9.021300, 7.850800, 6.865700, 6.103800, 5.340900, 9 4.761100, 4.279100, 3.878500, 3.582800, 3.265500, 9 3.066900, 2.850900, 2.634500, 2.409800, 2.172300, 9 1.938400, 1.788800, 1.556400, 1.402900, 1.276180, 9 1.188650, 0.277200, 0.864132, 0.808520, 0.751536, 9 0.698655, 0.644600, 0.594600, 0.547600, 5.830300, 9 5.303400, 4.817420, 4.347000, 3.928200, 3.569000, 9 3.216000, 2.948170, 2.812190, 2.773930, 2.662480, 9 2.562700, 2.472740, 2.387900, 2.253410, 2.242560, 9 2.180200, 2.070510, 2.073560, 2.028590, 1.988900, 9 1.901820, 1.832620, 1.773330, 1.720290, 1.671910, 9 1.629030, 1.592790, 1.512930, 0.461100, 0.545000, 9 0.655150, 0.690200, 0.704000, 0.700999, 0.685870, 9 0.663100, 0.646453, 0.616341, 0.589092, 0.563359, 9 0.547751, 0.529300, 0.511929, 0.499384, 0.483629, 9 0.465154, 0.451018, 0.437533/ DATA BLT/0.262003,0.630900, 0.750800, 1.127800, 1.332600, 9 1.020000, 3.132200, 2.286800, 2.641200, 3.112500, 9 3.173600, 2.173500, 1.900200, 3.035300, 4.179100, 9 5.203400, 7.196400, 6.772300, 7.439800, 7.387300, 9 7.367900, 7.355800, 7.351100, 7.353700, 7.357300, 9 7.357300, 7.340900, 7.292000, 7.167600, 7.031800, 9 6.700600, 6.374700, 6.070100, 5.819600, 5.235800, 9 6.728600, 9.643500, 9.818400, 10.294600, 10.948000, 9 12.014400, 17.235600, 11.094800, 12.918200, 14.350100, 9 15.501700, 16.688499, 17.644400, 18.559601, 19.100500, 9 19.045500, 19.013800, 18.994900, 19.029800, 19.106199, 9 19.297001, 19.599001, 19.769501, 19.669701, 19.684700, 9 19.609501, 19.425800, 19.088600, 19.079800, 18.218500, 9 17.638300, 17.294001, 16.428499, 15.885100, 15.434500, 9 15.220800, 15.172600, 15.229300, 15.430000, 15.718900, 9 16.155001, 16.729601, 17.763901, 18.591299, 19.041700, 9 19.158400, 13.063700, 12.951000, 15.473300, 19.021099, 9 21.281601, 23.054701, 22.906401, 23.103201, 23.421900, 9 23.294800, 23.412800, 23.596399, 23.808300, 24.099199, 9 24.409599, 24.773600, 25.199499/ DATA BST/7.740390,3.356800, 1.052400, 1.862300, 1.021000, 9 10.207500, 9.893300, 5.701100, 4.294400, 3.426200, 9 8.842200, 79.261101, 0.742600, 32.333698, 27.157000, 9 22.215099, 1.166200, 14.840700, 0.774800, 0.659900, 9 0.572900, 0.500000, 0.438500, 0.392000, 0.343200, 9 0.307200, 0.278400, 0.256500, 0.247000, 0.233300, 9 0.241200, 0.251600, 0.264700, 0.272600, 16.579599, 9 16.562300, 17.315100, 14.098800, 12.800600, 11.916000, 9 11.766000, 1.095800, 8.144870, 8.434670, 8.217580, 9 7.989290, 7.472600, 6.908900, 6.377600, 0.503100, 9 0.460700, 0.420885, 0.381400, 0.344000, 0.310700, 9 0.275600, 0.244475, 0.226836, 0.222087, 0.210628, 9 0.202088, 0.196451, 0.194200, 0.181951, 0.196143, 9 0.202172, 0.197940, 0.223545, 0.238849, 0.257119, 9 9.985190, 9.599900, 9.370460, 9.225900, 9.092270, 9 8.979480, 8.865530, 8.811740, 8.621600, 8.448400, 9 8.707510, 2.357600, 2.923800, 3.550780, 3.974580, 9 4.069100, 4.176190, 3.871350, 3.651550, 3.462040, 9 3.415190, 3.325300, 3.253960, 3.263710, 3.206470, 9 3.089970, 3.046190, 3.007750/ DATA CLT/0.196767,0.311200, 0.617500, 0.539100, 1.097900, 9 1.588600, 2.012500, 1.546300, 1.517000, 1.454600, 9 1.267400, 1.226900, 1.593600, 1.989100, 1.780000, 9 1.437900, 6.255600, 0.653900, 1.051900, 1.589900, 9 1.640900, 1.699100, 2.070300, 3.324000, 3.019300, 9 3.522200, 4.003400, 4.443800, 5.615800, 5.165200, 9 4.359100, 3.706800, 3.431300, 3.973100, 5.637700, 9 5.549300, 5.139900, 5.422000, 5.726290, 5.417320, 9 4.041830, 12.887600, 4.649010, 4.863370, 4.734250, 9 5.295370, 4.804500, 4.461000, 4.294800, 4.458500, 9 5.037100, 6.144870, 7.513800, 8.976700, 10.662000, 9 10.888000, 11.372700, 11.851300, 12.385600, 12.774000, 9 13.123500, 13.439600, 13.760300, 13.851800, 14.316700, 9 14.559600, 14.558300, 14.977900, 15.154200, 15.308700, 9 15.100000, 14.758600, 14.513500, 14.432700, 14.556400, 9 14.930500, 15.611500, 15.713100, 25.558201, 21.657499, 9 15.538000, 18.441999, 16.587700, 13.113800, 9.498870, 9 8.003700, 12.143900, 12.473900, 12.597700, 12.747300, 9 14.189100, 14.949100, 15.640200, 16.770700, 17.341499, 9 17.399000, 17.891899, 18.331699/ DATA CST/49.551899,22.927601,85.390503,103.483002, 60.349800, 9 0.568700, 28.997499, 0.323900, 0.261500, 0.230600, 9 0.313600, 0.380800, 31.547199, 0.678500, 0.526000, 9 0.253600, 18.519400, 43.898300, 213.186996, 85.748398, 9 136.108002, 35.633801, 26.893801, 20.262600, 17.867399, 9 15.353500, 13.535900, 12.176300, 11.396600, 10.316300, 9 10.780500, 11.446800, 12.947900, 15.237200, 0.260900, 9 0.226100, 0.274800, 0.166400, 0.125599, 0.117622, 9 0.204785, 11.004000, 21.570700, 24.799700, 25.874901, 9 25.205200, 24.660500, 24.700800, 25.849899, 26.890900, 9 27.907400, 28.528400, 27.766001, 26.465900, 24.387899, 9 20.207300, 18.772600, 17.608299, 16.766899, 15.885000, 9 15.100900, 14.399600, 13.754600, 12.933100, 12.664800, 9 12.189900, 11.440700, 11.360400, 10.997500, 10.664700, 9 0.261033, 0.275116, 0.295977, 0.321703, 0.350500, 9 0.382661, 0.417916, 0.424593, 1.482600, 1.572900, 9 1.963470, 8.618000, 8.793700, 9.556420, 11.382400, 9 14.042200, 23.105200, 19.988701, 18.599001, 17.830900, 9 16.923500, 16.092699, 15.362200, 14.945500, 14.313600, 9 13.434600, 12.894600, 12.404400/ DATA DLT/0.049879,0.178000, 0.465300, 0.702900, 0.706800, 9 0.865000, 1.166300, 0.867000, 1.024300, 1.125100, 9 1.112800, 2.307300, 1.964600, 1.541000, 1.490800, 9 1.586300, 1.645500, 1.644200, 0.865900, 1.021100, 9 1.468000, 1.902100, 2.057100, 1.492200, 2.244100, 9 2.304500, 2.348800, 2.380000, 1.673500, 2.410000, 9 2.962300, 3.683000, 4.277900, 4.354300, 3.985100, 9 3.537500, 1.529200, 2.669400, 3.265880, 3.657210, 9 3.533460, 3.742900, 2.712630, 1.567560, 1.289180, 9 0.605844, 1.046300, 1.602900, 2.039600, 2.466300, 9 2.682700, 2.523900, 2.273500, 1.990000, 1.495300, 9 2.695900, 3.287190, 3.330490, 2.824280, 2.851370, 9 2.875160, 2.896040, 2.922700, 3.545450, 2.953540, 9 2.965770, 3.638370, 2.982330, 2.987060, 2.989630, 9 3.716010, 4.300130, 4.764920, 5.119820, 5.441740, 9 5.675890, 5.833770, 5.783700, 5.860000, 5.967600, 9 5.525930, 5.969600, 6.469200, 7.025880, 7.425180, 9 7.443300, 2.112530, 3.210970, 4.086550, 4.807030, 9 4.172870, 4.188000, 4.185500, 3.479470, 3.493310, 9 4.216650, 4.232840, 4.243910/ DATA DST/2.201590,0.982100,168.261002, 0.542000, 0.140300, 9 51.651199, 0.582600, 32.908901, 26.147600, 21.718399, 9 129.423996, 7.193700, 85.088600, 81.693703, 68.164497, 9 56.172001, 47.778400, 33.392899, 41.684101, 178.436996, 9 51.353100, 116.105003, 102.477997, 98.739899, 83.754303, 9 76.880501, 71.169197, 66.342102, 64.812599, 58.709702, 9 61.413502, 54.762501, 47.797199, 43.816299, 41.432800, 9 39.397202, 164.934006, 132.376007, 104.353996, 87.662697, 9 69.795700, 61.658401, 86.847198, 94.292801, 98.606201, 9 76.898598, 99.815598, 87.482498, 92.802902, 83.957100, 9 75.282501, 70.840302, 66.877602, 64.265800, 213.904007, 9 167.201996, 133.123993, 127.112999, 143.643997, 137.903000, 9 132.720993, 128.007004, 123.174004, 101.398003, 115.362000, 9 111.874001, 92.656601, 105.703003, 102.960999, 100.417000, 9 84.329803, 72.028999, 63.364399, 57.056000, 52.086102, 9 48.164700, 45.001099, 38.610298, 36.395599, 38.324600, 9 45.814899, 47.257900, 48.009300, 47.004501, 45.471500, 9 44.247299, 150.645004, 142.324997, 117.019997, 99.172203, 9 105.250999, 100.612999, 97.490799, 105.980003, 102.273003, 9 88.483398, 86.002998, 83.788101/ DATA ELT/0.001305,0.006400, 0.037700, 0.038500, -0.193200, 9 0.215600, -11.529000, 0.250800, 0.277600, 0.351500, 9 0.676000, 0.858400, 1.115100, 1.140700, 1.114900, 9 0.866900, -9.557400, 1.444500, 1.422800, 1.375100, 9 1.332900, 1.280700, 1.219900, 1.183200, 1.089600, 9 1.036900, 1.011800, 1.034100, 1.191000, 1.304100, 9 1.718900, 2.131300, 2.531000, 2.840900, 2.955700, 9 2.825000, 3.487300, 2.506400, 1.912130, 2.069290, 9 3.755910, 4.387500, 5.404280, 5.378740, 5.328000, 9 5.265930, 5.179000, 5.069400, 4.939100, 4.782100, 9 4.590900, 4.352000, 4.071200, 3.711800, 3.335200, 9 2.773100, 2.146780, 1.862640, 2.058300, 1.984860, 9 2.028760, 2.209630, 2.574500, 2.419600, 3.583240, 9 4.297280, 4.567960, 5.920460, 6.756210, 7.566720, 9 7.976280, 8.581540, 9.243540, 9.887500, 10.472000, 9 11.000500, 11.472200, 11.688300, 12.065800, 12.608900, 9 13.174600, 13.411800, 13.578200, 13.677000, 13.710800, 9 13.690500, 13.724700, 13.621100, 13.526600, 13.431400, 9 13.428700, 13.396600, 13.357300, 13.381200, 13.359200, 9 13.288700, 13.275400, 13.267400/ DO 150 I=1,NK C CHECK ATOM TYPE DO 120 J=1,98 IF (NW(I).NE.N1(J)) GO TO 120 NO(I)=J TEST=AL(I)+BL(I)+CL(I)+ABS(DL(I))+ABS(EL(I)) C TEST IF THE PARAMETERS HAVE BEEN INPUT BY USER IN A KEYWORD FILE IF (TEST.GT.0.001) GO TO 120 AS(I)=AST(J) AL(I)=ALT(J) BS(I)=BST(J) BL(I)=BLT(J) CL(I)=CLT(J) CS(I)=CST(J) DL(I)=DLT(J) DS(I)=DST(J) EL(I)=ELT(J) 120 CONTINUE 150 CONTINUE RETURN END ************************************************************************ * * * A U U TTTTTTT OOOOO GGGGG PPPPPP * * A A U U T O O G G P P * * A A U U T O O G P P * * A A U U T O O G GGGG PPPPPP * * AAAAAAA U U T O O G G P * * A A U U T O O G G P * * A A UUUUU T OOOOO GGGGGG P * * * * SEARCH FOR THE PSEUDO-SYSTEMATIC EXTINCTION RULE AND * * PREPARE FOR AUTOMATIC GROUPING OF THE REFLECTIONS * * VERSION 1998 * ************************************************************************ SUBROUTINE AUTOGP(LATT,EMIN) COMMON/REFLXIN/LH(600),LK(600),LL(600),FO(600),ID(600),RHO(600), 1 SIG(600),XKP(600) COMMON/REFLXOUT/INX(3,30000),EX(30000) COMMON/RESCALING/ISC,IBGR,MG,MIG(8),SCL,BT(9),SC(9),IP(8,3,5), 1 SCAL(8) COMMON/WILSON/FLGW(30,9),FLGD(30,9),AVR(30,9),DCV(50,9),SLOPE(9), 1 FLGK(9),DEL(9),KS(9),EW(600),ED(600),EDP(600) DIMENSION EDX(3,256),EDX1(3,256),MDX(3),ICX(3),IN(3), 1 IP6(6,5),ILSYM(3) WRITE (6,10) 10 FORMAT(//9X,45H*** AUTOMATIC SEARCH FOR PSEUDO - SYSTEMATIC , & 14HEXTINCTION ***) DO 40 I=1,3 IN(I)=0 ICX(I)=1 ILSYM(I)=2 DO 30 J=1,256 EDX(I,J)=0.0 EDX1(I,J)=0.0 30 CONTINUE 40 CONTINUE DO 50 I=1,6 DO 50 J=1,5 IP6(I,J)=0 50 CONTINUE C STORE THE SYSTEMATIC EXTINCTION RULES DUE TO LATTICE CENTERING IF (LATT.EQ.1) GO TO 200 K=LATT-1 GO TO (100,110,120,200,200,150), K 100 ILSYM(1)=1 GO TO 200 110 ILSYM(2)=1 GO TO 200 120 ILSYM(3)=1 GO TO 200 150 DO 160 I=1,3 ILSYM(I)=3 160 CONTINUE C READ REFLECTION FILE, STORE SEPARATIVELY THE ABSOLUTE VALUES OF C INDICES H, K, L AND THE CUMULATED E**2 VALUES 200 M=MG+1 NB=0 REWIND 8 210 READ (8) LH,LK,LL,FO,ID,EW,ED,RHO DO 220 I=1,600 IF (FO(I).LT.0.0) GO TO 222 ED(I)=SC(1)*ED(I)*EXP(2.0*BT(1)*RHO(I)) IF (SQRT(ED(I)).LT.EMIN) GO TO 220 C PICK UP REFLECTIONS WITH E GREATER THAN EMIN IH=IABS(LH(I)) IK=IABS(LK(I)) IL=IABS(LL(I)) IF (IH.NE.0) EDX(1,IH)=EDX(1,IH)+ED(I) IF (IK.NE.0) EDX(2,IK)=EDX(2,IK)+ED(I) IF (IL.NE.0) EDX(3,IL)=EDX(3,IL)+ED(I) C STORE UP TO 15000 STRONG REFLECTIONS FOR LATER USE NB=NB+1 INX(1,NB)=LH(I) INX(2,NB)=LK(I) INX(3,NB)=LL(I) EX(NB)=ED(I) IF (NB.EQ.15000) GO TO 222 220 CONTINUE GO TO 210 222 WRITE (6,224) NB 224 FORMAT(24X,I6,2X,'LARGEST E**2 WERE USED'/) DO 230 I=1,3 DO 228 J=1,256 EDX1(I,J)=EDX(I,J) 228 CONTINUE 230 CONTINUE C FIND THE ONE-INDEX-RELATIONS FOR THE 'STRONG' RELECTION GROUP NRLN=0 CALL GCD(EDX,ICX,INDEX,SCL,IP,IP6,NRLN) IF (INDEX.EQ.1) GO TO 250 DO 240 I=1,3 IF (ICX(I).EQ.1) GO TO 240 NRLN=NRLN+1 IP6(NRLN,I)=1 IP6(NRLN,4)=ICX(I) ICX(I)=1 240 CONTINUE C FIND THE THREE INDEX-DIFFERENCES FOR EACH PAIR OF REFLECTIONS, C STORE ONE INDEX-DIFFERENCE WHEN THE OTHER TWO EQUAL ZERO 250 DO 265 I=1,3 DO 260 J=1,256 EDX(I,J)=0.0 260 CONTINUE 265 CONTINUE DO 450 I=1,NB N=I+1 DO 400 J=N,NB DO 310 K=1,3 MDX(K)=IABS(INX(K,I)-INX(K,J)) 310 CONTINUE DO 320 K=1,3 IF (MDX(K).EQ.0) GO TO 320 KSW=0 DO 314 KK=1,3 IF (KK.EQ.K) GO TO 314 IF (MDX(KK).NE.0) GO TO 314 KSW=KSW+1 IF (KSW.NE.2) GO TO 314 MX=MDX(K) EDX(K,MX)=EDX(K,MX)+EX(I)+EX(J) 314 CONTINUE 320 CONTINUE 400 CONTINUE 450 CONTINUE WRITE (6,456) 456 FORMAT(/1X,' H SIGMA K SIGMA L SIGMA',3X, & 'DELTA H SIGMA DELTA K SIGMA DELTA L SIGMA'/ & 1X,3(5X,4HE**2),1X,3(11X,4HE**2)/) WRITE (6,458)(I,EDX1(1,I),I,EDX1(2,I),I,EDX1(3,I),I,EDX(1,I), & I,EDX(2,I),I,EDX(3,I),I=1,16) 458 FORMAT((1X,3(I3,F6.1),2X,3(5X,I3,F7.1))) CALL GCD(EDX,ICX,INDEX,SCL,IP,IP6,NRLN) C REJECT INDEX-DIFFERENCE RELATIONS DUE TO LATTICE CENTERING IF (LATT.EQ.1) GO TO 510 DO 500 I=1,3 IF (ICX(I).EQ.1.OR.ICX(I).NE.ILSYM(I)) GO TO 500 ICX(I)=1 INDEX=INDEX-1 500 CONTINUE 510 IF (INDEX.GT.2) GO TO 680 IF (NRLN.GT.0) GO TO 1105 GO TO 1200 C FIND THE RELATIONS INVOLVING TWO INDICES 680 NRS=NRLN NRS2=NRLN DO 760 I=1,2 N=I+1 DO 740 J=N,3 DO 700 J1=1,3 IN(J1)=0 700 CONTINUE CALL COMMUL(ICX(I),ICX(J),1,ICOM) DO 720 K=2,3 IS=(-1)**K IN(I)=ICOM/ICX(I) IN(J)=IS*ICOM/ICX(J) CALL RCHECK(IN,ICOM,NRLN,JUMP,NB,IP6) IF (NRLN-NRS.EQ.2) GO TO 770 IF (JUMP.EQ.1) GO TO 740 IF (ICOM.EQ.2) GO TO 740 720 CONTINUE 740 CONTINUE 760 CONTINUE 770 NRS2=NRLN IF (INDEX.LT.4) GO TO 1000 C RELATION INVOLVING THREE INDICES CALL COMMUL(ICX(1),ICX(2),ICX(3),ICOM) IN(3)=ICOM/ICX(3) DO 800 I=2,3 IS=(-1)**I IN(1)=IS*ICOM/ICX(1) DO 790 K=2,3 KKS=(-1)**K IN(2)=KKS*ICOM/ICX(2) CALL RCHECK(IN,ICOM,NRLN,JUMP,NB,IP6) IF (JUMP.EQ.1) GO TO 1000 790 CONTINUE 800 CONTINUE 1000 IF (NRLN.EQ.NRS) GO TO 1105 C CHECK FOR THE INDEPENDENCY OF THE INDEX RELATIONS NRLNT=NRLN NRS1=NRS+1 IF (NRLN.EQ.NRS2.OR.NRS2.EQ.NRS) GO TO 1045 C SIMULTANEOUS EXISTENCE OF 2- AND 3-INDEX RELATIONS IS NOT ALLOWED DO 1020 I=NRS1,NRS2 IF (IP6(I,5).GT.IP6(NRLN,5)) GO TO 1020 C DELETE 3-INDEX RELATION DO 1010 J=1,5 IP6(NRLN,J)=0 1010 CONTINUE NRLN=NRLN-1 GO TO 1045 1020 CONTINUE C DELETE 2-INDEX RELATIONS DO 1040 I=NRS1,NRS2 DO 1030 J=1,5 IP6(I,J)=0 1030 CONTINUE NRLN=NRLN-1 1040 CONTINUE 1045 IF (NRS.EQ.0) GO TO 1105 C DELETE 1-INDEX RELATION IF IT IS INCLUDED IN ANOTHER RELATION OR C IN THE COMBINATION OF OTHER RELATIONS NR0=NRS DO 1100 I=1,NRS J=NRS1-I DO 1050 K=1,3 IF (IP6(J,K).EQ.1) GO TO 1052 1050 CONTINUE 1052 DO 1090 L=NRS1,NRLNT IF (IP6(L,4).EQ.0.OR.IP6(L,K).EQ.0) GO TO 1090 II=1 DO 1054 M=1,4 IF (M.EQ.K) GO TO 1054 IN(II)=IP6(L,M) II=II+1 1054 CONTINUE IC=IP6(L,K) CALL GCD3(IN,IC,JUMP) IF (JUMP.EQ.1) GO TO 1066 DO 1064 II=1,4 IP6(J,II)=0 1064 CONTINUE NR0=NR0-1 1066 IF (NR0.LT.2) GO TO 1090 DO 1070 II=1,3 IN(II)=0 IF (NRLNT.GT.NRS2.AND.IP6(NRLNT,4).NE.0) IN(II)=1 1070 CONTINUE II=1 DO 1080 M=1,3 IF (M.EQ.J) GO TO 1080 DO 1078 MM=1,NRS IF (IP6(MM,4).EQ.0) GO TO 1078 IF (MM.EQ.J) GO TO 1078 IF (IP6(MM,M).EQ.0.OR.IP6(L,M).EQ.0) GO TO 1078 IN(II)=IP6(MM,4)*IP6(L,MM) II=II+1 1078 CONTINUE 1080 CONTINUE IF (II.EQ.1) GO TO 1090 IN(II)=IP6(L,4) IC=IP6(L,K) CALL GCD3(IN,IC,JUMP) IF (JUMP.EQ.1) GO TO 1100 DO 1088 II=1,4 IP6(J,II)=0 1088 CONTINUE NR0=NR0-1 1090 CONTINUE 1100 CONTINUE 1105 NRLN=0 DO 1110 I=1,6 IF (IP6(I,4).EQ.0) GO TO 1110 NRLN=NRLN+1 DO 1120 J=1,4 IP(1,NRLN,J)=IP6(I,J) IP6(I,J)=0 1120 CONTINUE 1110 CONTINUE IF (NRLN.GT.0) GO TO 1500 1200 WRITE (6,1210) 1210 FORMAT(/1X,12X,45H*** NO PSEUDO-TRANSLATIONAL SYMMETRY HAS BEEN, & 10H FOUND ***/) RETURN C SET UP INDEX RELATIONS FOR THE WEAK GROUPS 1500 MG=1 DO 1510 I=1,NRLN MG=MG*IP(1,I,4) 1510 CONTINUE IF (MG.LE.8) GO TO 1520 MG=2 GO TO 1620 1520 DO 1600 I=2,MG DO 1580 J=1,NRLN DO 1560 K=1,4 IP(I,J,K)=IP(1,J,K) 1560 CONTINUE IF (NRLN-J.NE.2) GO TO 1565 IP(I,J,5)=MOD((I-1)/(IP(1,NRLN,4)*IP(1,NRLN-1,4)),IP(1,J,4)) GO TO 1580 1565 IF (NRLN-J.EQ.1) IP(I,J,5)=MOD((I-1)/IP(1,NRLN,4),IP(1,J,4)) IF (NRLN-J.EQ.0) IP(I,J,5)=MOD(I-1,IP(1,J,4)) 1580 CONTINUE 1600 CONTINUE 1620 ISC=2 IBGR=1 C CHECK FOR NULL 'WEAK' GROUPS II=0 MG1=MG DO 1700 NI=2,MG I=NI-II ESIG=0 REWIND 8 1630 READ (8) LH,LK,LL,FO,ID,EW,ED DO 1660 N=1,600 IF (FO(N).LT.0.0) GO TO 1665 DO 1650 J=1,3 IF (IP(I,J,4).EQ.0) GO TO 1650 IF (MOD(IP(I,J,1)*LH(N)+IP(I,J,2)*LK(N)+IP(I,J,3)*LL(N)-IP(I,J,5) & ,IP(I,J,4)).NE.0) GO TO 1660 1650 CONTINUE ESIG=ESIG+ED(N) 1660 CONTINUE N=N-1 1665 IF (ESIG.GT.0.000001) GO TO 1700 IF (FO(N).GE.0.0) GO TO 1630 MG1=MG1-1 DO 1690 K=I,MG1 DO 1680 J=1,3 DO 1670 JJ=1,5 IP(K,J,JJ)=IP(K+1,J,JJ) 1670 CONTINUE 1680 CONTINUE 1690 CONTINUE II=1+II 1700 CONTINUE MG=MG1 CALL SCRWRT WRITE (6,1800) 1800 FORMAT(//6X,48H*** PSEUDO-TRANSLATIONAL SYMMETRY HAS BEEN FOUND, & 19H BY THE PROGRAM ***//16X,'*** INTENSITY DATA ARE TO BE RE-', & 'NORMALIZED ***'//2X,'*** IT IS NOT RECOMMENDED TO SOLVE THE', & ' STRUCTURE BY PATTERSON ANALYSIS ***'/) RETURN END C ----------------------- SUBROUTINE COMMUL(I1,I2,I3,ICOM) C FIND A LEAST COMMON MULTIPLE FOR THE INCREMENTS C OF DIFFERENT INDICES DIMENSION IN(3) IN(1)=I1 IN(2)=I2 IN(3)=I3 ICOM=1 50 DO 300 J=2,256 DO 100 I=1,3 IF (MOD(IN(I),J).EQ.0) GO TO 150 100 CONTINUE 300 CONTINUE GO TO 400 150 DO 250 I=1,3 IF (MOD(IN(I),J).EQ.0) IN(I)=IN(I)/J 250 CONTINUE ICOM=ICOM*J DO 350 I=1,3 IF (IN(I).NE.1) GO TO 50 350 CONTINUE 400 RETURN END C ------------------------------------ SUBROUTINE GCD(EDX,ICX,INDEX,SCL,IP,IP6,NRLN) C FIND THE GREATEST COMMON DIVISORS FOR THE INCREMENTS C OF H K AND L OF THE STRONG REFLECTIONS DIMENSION EDX(3,256),ICX(3),SED(256),IP(8,3,5),IP6(6,5) DO 600 I=1,3 SIGE=0.0 DO 400 J=1,256 SED(J)=0.0 SIGE=SIGE+EDX(I,J) 400 CONTINUE DO 500 J=2,256 IF (EDX(I,J).LT.0.01) GO TO 500 DO 450 K=1,256 IF (EDX(I,K).LT.0.01) GO TO 450 IF (MOD(K,J).EQ.0) GO TO 450 SED(J)=SED(J)+EDX(I,K) 450 CONTINUE 500 CONTINUE SED(1) = 10000000.0 DO 550 J=2,256 IF (NRLN.EQ.0) GO TO 512 DO 510 N=1,NRLN IF (IP6(N,I).EQ.1.AND.IP6(N,4).EQ.J) EDX(I,J)=0.0 510 CONTINUE 512 IF (EDX(I,J).LT.0.01) GO TO 550 IF (SED(J)/SIGE.LT.SCL*0.6) GO TO 520 EDX(I,J)=0.0 GO TO 550 520 IF (SED(J).GT.SED(1)) GO TO 550 SED(1) = SED(J) ICX(I) = J 550 CONTINUE DO 570 J=2,256 IF (EDX(I,J).LT.0.01) GO TO 570 IF (MOD(J,ICX(I)).EQ.0) ICX(I)=J 570 CONTINUE 600 CONTINUE INDEX=1 DO 700 I=1,3 IF (ICX(I).GT.1) INDEX=INDEX+1 700 CONTINUE RETURN END C ------------------ SUBROUTINE GCD3(IN,IC,JUMP) C FIND THE GREATEST COMMON DIVISOR FOR THREE INTEGERS DIMENSION IN(3) JUMP=0 DO 200 I=1,9 J=10-I DO 100 K=1,3 IF (MOD(IN(K),J).NE.0) GO TO 200 100 CONTINUE GO TO 300 200 CONTINUE 300 IF (J.EQ.1.OR.MOD(J,IC).NE.0) JUMP=1 RETURN END C ---------------------------------- SUBROUTINE RCHECK(IN,ICOM,NRLN,JUMP,NB,IP6) C CHECK INDEX RELATIONSHIPS COMMON/REFLXOUT/INX(3,30000),EX(30000) COMMON/RESCALING/ISC,IBGR,MG,MIG(8),SCL,BT(9),SC(9),IP(8,3,5), 1 SCAL(8) DIMENSION IN(3),IP6(6,5) EBOT=0.0 ETOP=0.0 JUMP=0 DO 100 I=1,NB EBOT=EBOT+EX(I) INSM=IN(1)*INX(1,I)+IN(2)*INX(2,I)+IN(3)*INX(3,I) IF (MOD(INSM,ICOM).NE.0) ETOP=ETOP+EX(I) 100 CONTINUE IF (ETOP/EBOT.GT.SCL*0.6) GO TO 400 NRLN=NRLN+1 DO 300 I=1,3 IP6(NRLN,I)=IN(I) 300 CONTINUE IP6(NRLN,4)=ICOM JUMP=1 IP6(NRLN,5)=INT(1000000.0*ETOP/EBOT) 400 RETURN END C -------- SUBROUTINE SCRWRT C REWRITE THE SCRATCH FILE COMMON/REFLXIN/LH(600),LK(600),LL(600),FO(600),ID(600),RHO(600), 1 SIG(600),XKP(600) COMMON/WILSON/FLGW(30,9),FLGD(30,9),AVR(30,9),DCV(50,9),SLOPE(9), 1 FLGK(9),DEL(9),KS(9),EW(600),ED(600),EDP(600) COMMON/XXX/P(6),CX(9),NREF CALL CCPDPN(7,'SCRA7.TM','SCRATCH','U',80,0) c OPEN(7,FILE='SCRA7.TM',FORM='UNFORMATTED',STATUS='UNKNOWN') NREF=0 REWIND 8 100 READ (8) LH,LK,LL,FO,ID,EW,ED,RHO,SIG WRITE (7) LH,LK,LL,FO,ID,EW,ED,RHO,SIG DO 200 I=1,600 IF (FO(I).LT.0.0) GO TO 300 200 CONTINUE GO TO 100 300 REWIND 8 REWIND 7 400 READ (7) LH,LK,LL,FO,SIG,SIG,SIG,SIG,SIG CALL FCAL DO 500 I=1,600 IF (FO(I).LT.0.0) GO TO 600 500 CONTINUE GO TO 400 600 close (7) c 600 CLOSE (7,STATUS='DELETE') RETURN END C----------------------------------------------------------------------- SUBROUTINE CURVK(ESQ,RHO,ED,IG) C K-CURVE INTERPOLATION COMMON/WILSON/FLGW(30,9),FLGD(30,9),AVR(30,9),DCV(50,9),SLOPE(9), 1 FLGK(9),DEL(9),KS(9) COMMON/XXX/P(6),CX(9),NREF,NB,RHOMAX,MM,EMAX,EN,MZ,ER,ISIM,RHOCUT 1 ,RHOMIN,RHOLOW EI=RHO*DEL(IG) I=EI C FOR SMALL RHO THE CURVE IS EXTRAPOLATED FROM THE FIRST POINT C USING THE LEAST SQUARES SLOPE IF (I.LT.KS(IG)) SK = DCV(KS(IG),IG)*EXP(SLOPE(IG)*(FLOAT(I)/ 1 DEL(IG)-RHO)) C INTERPOLATION IF (I.GE.KS(IG).AND.I.LT.50) SK=DCV(I,IG)+(EI-FLOAT(I))*(DCV(I+1, 1 IG)-DCV(I,IG)) C FOR LARGE RHO THE CURVE IS EXTRAPOLATED FROM THE LAST POINT IF (I.GE.50) SK=DCV(50,IG)*EXP(SLOPE(IG)*(AVR(NB,IG)-RHO)) ESQ=ED/SK RETURN END C----------------------------------------------------------------------- SUBROUTINE DATAIN(MH,MK,ML) C READ REFLEXIONS FROM DATA FILE COMMON/REFLXIN/LH(600),LK(600),LL(600),FO(600),ID(600),RHO(600), 1 SIG(600),XKP(600) COMMON/REFLXOUT/IX(30000),EX(30000),FX(30000),SCMK(30000) COMMON/RESCALING/ISC,IBGR,MG,MIG(8),SCL,BT(9),SC(9),IP(8,3,5), 1 SCAL(8) COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT, 1 IAVE,EXTI COMMON/XXX/ P(6),CX(9),NREF,NB,RHOMAX,MM,EMAX,EN,MZ,ER,ISIM,RHOCUT REAL RSYM(4,4,64),CELLP(6) DIMENSION ADATA1(5),I1(3),I2(3),KL3(24) integer IFLAG(24),JFLAG(24) CHARACTER ITLE INTEGER IPOINT1(5) CHARACTER*30 LAB1(5),LSUSRJ(5) CHARACTER*1 CTYP1(5) LOGICAL EOF,LOGMSS(5) CHARACTER*4 KEY, CCVAL(20) CHARACTER*400 LINE CHARACTER NCH(7), LTYPEX*1,PGNAMX*10,SPGRNX*10 INTEGER NTOK, IBEG(20), IEND(20), ITYP(20), IDEC(20) REAL FVAL(20) DATA ADATA1/5*0.0/ DATA LAB1/'H','K','L','DF','SIGDF'/ DATA CTYP1/'H','H','H','D','Q'/ DATA IPOINT1/-1,-1,-1,2*0/ DATA NCH/'A','B','C','I','R','F','P'/ rewind (10) c CALL CCPDPN(10,'KEYWORD.TM','UNKNOWN','F',80,0) c OPEN(10,FILE='KEYWORD.TM',FORM='FORMATTED',STATUS='UNKNOWN') 10 READ(10,'(A132)',END=15) LINE NTOK = 20 CALL PARSER (KEY,LINE,IBEG,IEND,ITYP,FVAL,CCVAL, + IDEC,NTOK,EOF,.FALSE.) CALL CCPUPC(KEY) IF (KEY.NE.'LABI') GO TO 10 GOTO 20 15 CALL CCPERR(1,' ---- LABIN card missing ---- ') 20 NL = 5 CALL MTZINI ITOK = 2 CALL LKYSET(LAB1,NL,LSUSRJ,IPOINT1,ITOK,NTOK,LINE, + IBEG,IEND) CALL LKYIN(1,LAB1,NL,NTOK,LINE,IBEG,IEND) CALL LROPEN (1,'HKLIN',1,IFAIL) IF (IFAIL.EQ.1) CALL CCPERR(1,'Error opening HKLIN') if (latt.eq.0) then CALL LRSYMM(1,NSYM,RSYM) call lrsymi(1,nsympx,ltypex,nspgrx,spgrnx,pgnamx) DO 22 I=1,7 IF (LTYPEX.EQ.NCH(I)) IN1=I 22 CONTINUE LATT=MOD(IN1,7)+1 IF (LATT.LE.5) PTS=MIN0(2,LATT) IF (LATT.GE.6) PTS=LATT-3 IF (IN1.EQ.6) LATT=6 IF (IN1.EQ.5) LATT=7 nsym = nsym/pts do n = 1, nsym do i = 1, 3 ts(i,n) = rsym(i,4,n) do j = 1, 3 is(i,j,n) = nint(rsym(j,i,n)) end do end do end do ksys = 1 if (nspgrx.ge.3.and.nspgrx.le.15) ksys = 2 if (nspgrx.ge.16.and.nspgrx.le.74) ksys = 3 if (nspgrx.ge.75.and.nspgrx.le.142) ksys = 4 if (nspgrx.ge.143.and.nspgrx.le.167) ksys = 5 if (nspgrx.ge.168.and.nspgrx.le.194) ksys = 6 if (nspgrx.ge.195) ksys = 8 end if if (cx(1).eq.0.0) then CALL LRCELL(1,CELLP) do i = 1, 6 cx(i) = cellp(i) end do call incell end if CALL LRASSN (1,LAB1,NL,IPOINT1,CTYP1) K=0 100 CALL LRREFF(1,RESOL,ADATA1,EOF) IF (EOF) GOTO 450 CALL LRREFM(1,LOGMSS) IF (LOGMSS(4)) GOTO 100 IF (adata1(4).EQ.0.) GOTO 100 c IF (abs(adata1(4)).lt.(2.*adata1(5))) GOTO 100 KH=ADATA1(1) KK=ADATA1(2) KL=ADATA1(3) F=ABS(ADATA1(4)) SD=ADATA1(5) C GENERATE SYMMETRY RELATED REFLEXIONS AND FIND STANDARD ONE. MAXI=1 I1(1)=KH I1(2)=KK I1(3)=KL KCEN = 0 DO 250 J=1,NSYM IFLAG(J) = 1 JFLAG(J) = 1 DO 220 I0=1,3 I2(I0)=IS(I0,1,J)*I1(1) + IS(I0,2,J)*I1(2) + IS(I0,3,J)*I1(3) 220 CONTINUE IF((I2(1)+I1(1)).EQ.0.AND.(I2(2)+I1(2)).EQ.0.AND. + (I2(3)+I1(3)).EQ.0) KCEN=1 IND=65536*I2(1)+256*I2(2)+I2(3) IF (IND.LT.0) IFLAG(J) = -1 c IF (IND.LT.0.AND.IDTYPE.EQ.-1) JFLAG(J) = -1 KL3(J)=32896+IABS(IND) IF(J.EQ.1) GOTO 250 JM1=J-1 DO 240 I0=1,JM1 IF(KL3(I0).EQ.KL3(J)) KL3(J)=0 240 CONTINUE IF(KL3(J).GT.KL3(MAXI)) MAXI=J 250 CONTINUE C UNPACKING STANDARD REFLEXIONS IND=KL3(MAXI) KH=IND/65536 IF(IND.LT.0) KH=KH-1 IND=IND-65536*KH KK=IND/256 KL=IND-256*KK-128 KK=KK-128 K=K+1 LH(K)=KH IF (MH.LT.KH) MH=KH LK(K)=KK IF (MK.LT.KK) MK=KK LL(K)=KL IF (ML.LT.KL) ML=KL FO(K)=F SIG(K)=1. 300 CONTINUE IF(K.NE.600) GOTO 100 C CALCULATE RHO, EPSILON, MULTIPLICITY, SCATTERING FACTOR AND C CREATE SCRATCH FILE CALL FCAL K=0 GOTO 100 450 FO(K+1) = -1.0 CALL FCAL CALL LRCLOS (1) CLOSE (10) RETURN END C--------------------------------------------------------------- SUBROUTINE AVERAGE(FM,NPC) CHARACTER FM*80 COMMON/XXX/P(6) DIMENSION LHKL(4,30000),FODS(2,30000) DIMENSION KH(10),KK(10),KL(10),F(10),KD(10) C INPUT REFLECTION DATA K=0 80 READ (3,FM) (KH(I),KK(I),KL(I),F(I),KD(I),I=1,NPC) DO 100 I=1,NPC IF (F(I).LT.0.0) GO TO 120 K=K+1 LHKL(1,K)=KH(I) LHKL(2,K)=KK(I) LHKL(3,K)=KL(I) LHKL(4,K)=KD(I) FODS(1,K)=F(I) FODS(2,K)= * 0.5/SQRT(P(1)*FLOAT(KH(I)*KH(I))+P(2)*FLOAT(KK(I)*KK(I)) 1 +P(3)*FLOAT(KL(I)*KL(I))+P(4)*FLOAT(KH(I)*KK(I)) 2 +P(5)*FLOAT(KH(I)*KL(I))+P(6)*FLOAT(KK(I)*KL(I))) IF(K.EQ.30000) GO TO 120 100 CONTINUE GO TO 80 120 CONTINUE C DATA DEALING PROCESS CALL SORTD(6,LHKL,FODS,K) CALL DATAV(LHKL,FODS,K) NUMB=0 DO 180 LN=1,K IF (LHKL(4,LN).EQ.2) GO TO 180 NUMB=NUMB+1 LHKL(1,NUMB)=LHKL(1,LN) LHKL(2,NUMB)=LHKL(2,LN) LHKL(3,NUMB)=LHKL(3,LN) LHKL(4,NUMB)=LHKL(4,LN) FODS(1,NUMB)=FODS(1,LN) 180 CONTINUE CALL SORTD(1,LHKL,FODS,NUMB) NUMB=NUMB+1 LHKL(1,NUMB)=10 LHKL(2,NUMB)=10 LHKL(3,NUMB)=10 LHKL(4,NUMB)=1 FODS(1,NUMB)=-100.0 REWIND 3 WRITE(3,'(A80)') FM WRITE(3,FM) (LHKL(1,LN),LHKL(2,LN),LHKL(3,LN),FODS(1,LN), * LHKL(4,LN),LN=1,NUMB) REWIND 3 READ (3,'(A80)') FM RETURN END C ----------- SUBROUTINE DATAV(LHKL,FODS,NUMB) C SELECTING STANDARD REFLECTION DATA COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT, 1 IAVE,EXTI DIMENSION LHKL(4,600000),FODS(2,600000),MKS(3,3,48), * LLH(48),LLK(48),LLL(48) MP=NSYM*2 DO 40 I=1,NSYM DO 35 J=1,3 DO 30 M=1,3 MKS(M,J,I)=IS(M,J,I) MKS(M,J,I+NSYM)=-IS(M,J,I) 30 CONTINUE 35 CONTINUE 40 CONTINUE LN=1 100 KC=1 IF (LHKL(4,LN).EQ.2) GO TO 160 DO 110 I=1,MP LLH(I)=MKS(1,1,I)*LHKL(1,LN)+MKS(1,2,I)*LHKL(2,LN)+ * MKS(1,3,I)*LHKL(3,LN) LLK(I)=MKS(2,1,I)*LHKL(1,LN)+MKS(2,2,I)*LHKL(2,LN)+ * MKS(2,3,I)*LHKL(3,LN) LLL(I)=MKS(3,1,I)*LHKL(1,LN)+MKS(3,2,I)*LHKL(2,LN)+ * MKS(3,3,I)*LHKL(3,LN) 110 CONTINUE LH0=LLH(1) LK0=LLK(1) LL0=LLL(1) DO 120 I=1,MP-1 IF (LLH(I+1).LT.LH0) GO TO 120 IF (LLH(I+1).EQ.LH0.AND.LLK(I+1).LT.LK0) GO TO 120 IF (LLH(I+1).EQ.LH0.AND.LLK(I+1).EQ.LK0.AND.LLL(I+1).LT.LL0) * GO TO 120 LH0=LLH(I+1) LK0=LLK(I+1) LL0=LLL(I+1) 120 CONTINUE ICH1=0 ICH2=0 DO 140 J=LN+1,NUMB DJN=ABS(FODS(2,J)-FODS(2,LN)) IF (DJN.GT.1E-6) GO TO 150 ICH1=ICH1+1 DO 130 I=1,MP IF(LHKL(1,J).NE.LLH(I).OR.LHKL(2,J).NE.LLK(I).OR. * LHKL(3,J).NE.LLL(I)) GO TO 130 ICH2=ICH2+1 FODS(1,LN)=FODS(1,LN)+FODS(1,J) KC=KC+1 LHKL(4,J)=2 GO TO 140 130 CONTINUE 140 CONTINUE 150 FODS(1,LN)=FODS(1,LN)/KC LHKL(1,LN)=LH0 LHKL(2,LN)=LK0 LHKL(3,LN)=LL0 160 LN=LN+1 IF(LN.LT.NUMB) GOTO 100 RETURN END C------------------------------------------------------- SUBROUTINE SORTD(IFLAG,LHKL,FODS,NUMB) DIMENSION LHKL(4,600000),FODS(2,600000),LH(4),FO(2) INT=NUMB 100 INT=INT/2 IF(2*(INT/2).EQ.INT) INT=INT-1 IFIN=NUMB-INT DO 1000 II=1,IFIN I=II J=I+INT IF (IFLAG.LE.4) GO TO 150 IF (FODS(2,I).LE.FODS(2,J)) GO TO 1000 A1= FODS(2,J) GO TO 160 150 IF (LHKL(1,I).LT.LHKL(1,J)) GO TO 1000 IA1= LHKL(1,J) IF (LHKL(1,I).EQ.LHKL(1,J).AND.LHKL(2,I).LT.LHKL(2,J)) GO TO 1000 IA2= LHKL(2,J) IF (LHKL(1,I).EQ.LHKL(1,J).AND.LHKL(2,I).EQ.LHKL(2,J).AND. * LHKL(3,I).LT.LHKL(3,J)) GO TO 1000 IA3= LHKL(3,J) 160 DO 200 K=1,4 LH(K)=LHKL(K,J) 200 CONTINUE DO 300 K=1,2 FO(K)=FODS(K,J) 300 CONTINUE 400 DO 500 K=1,4 LHKL(K,J)=LHKL(K,I) 500 CONTINUE DO 600 K=1,2 FODS(K,J)=FODS(K,I) 600 CONTINUE J=I I=I-INT IF(I.LE.0) GOTO 700 IF (IFLAG.LE.4) GO TO 650 IF(FODS(2,I).GT.A1) GOTO 400 GO TO 700 650 IF(LHKL(1,I).GT.IA1) GOTO 400 IF(LHKL(1,I).EQ.IA1.AND.LHKL(2,I).GT.IA2) GO TO 400 IF(LHKL(1,I).EQ.IA1.AND.LHKL(2,I).EQ.IA2.AND. * LHKL(3,I).GT.IA3) GO TO 400 700 DO 800 K=1,4 LHKL(K,J)=LH(K) 800 CONTINUE DO 900 K=1,2 FODS(K,J)=FO(K) 900 CONTINUE 1000 CONTINUE IF(INT.GT.1) GOTO 100 RETURN END C ----------------------------------------------------------------- C THIS PROGRAM IS USED FOR CHECKING AND REJECTING THE REFLEXIONS C WITH SYSTEMATIC EXTINTION SUBROUTINE REJECT(IEXT,I1) COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT, 1 IAVE,EXTI DIMENSION I1(3),T(3) IHKL=I1(1)+I1(2) C LATT. CENTERED (P:500 A:400 B:200 C:450 I:300 F:350 R:100) GO TO (500,400,200,450,300,350,100) LATT 100 IF (MOD((IHKL+I1(1)+I1(3)),3).EQ.0) GO TO 500 GO TO 1000 200 IHKL=I1(1)+I1(3) GO TO 450 300 IHKL=IHKL+I1(3) GO TO 450 350 IF (MOD(IHKL,2).EQ.0) GO TO 400 GO TO 1000 400 IHKL=I1(2)+I1(3) 450 IF (MOD(IHKL,2).EQ.0) GO TO 500 GO TO 1000 500 IF (EXTI.LT.0.01) GO TO 1100 TEMP1=-999999.0 RECY=0.0 DO 980 J=1,NSYM DO 900 L=1,3 T(L)=IS(L,1,J)*I1(1) + IS(L,2,J)*I1(2) + IS(L,3,J)*I1(3) 900 CONTINUE IF (49.5-AMAX1(ABS(T(1)),ABS(T(2)))) 1100,1100,950 950 TEMP2=T(1)+100.00*(T(2)+100.0*T(3)) IF (ICENT.EQ.1) TEMP2=ABS(TEMP2) IF (TEMP2-TEMP1+0.01) 980,960,960 960 ANG=6.283185*(I1(1)*TS(1,J)+I1(2)*TS(2,J)+I1(3)*TS(3,J)) SUM=COS(ANG) C FOR THE ACENTRIC CASE IF (ICENT.EQ.0) SUM=SUM+100.0*SIN(ANG) ANG=SUM RECY=RECY+ANG IF (TEMP2-TEMP1-0.05) 980,970,970 970 RECY=ANG TEMP1=TEMP2 980 CONTINUE IF (ABS(RECY)-0.01) 1000,1100,1100 C FOR THE CASE OF SYSTEMATIC EXTINCTION 1000 IEXT=1 RETURN C FOR THE CASE OF NON-SYSTEMATIC EXTINCTION 1100 IEXT=0 RETURN END C----------------------------------------------------------------------- SUBROUTINE DEBYE(NMEM,NTOT,CR,POP) C CALCULATE SCATTERING FACTORS FOR RANDOM GROUPS (NINF = 2) COMMON/ATMFACTOR/AL(8),AS(8),BL(8),BS(8),CL(8),CS(8),DL(8),DS(8), 1 EL(8),NW(8),NO(8),NK,NAT,F(9) COMMON/ATMGROUP/NINF(10),NAG(10),X(5000),Y(5000),Z(5000),NZ(5000), 1 Q(5000),U11(5000),U22(5000),U33(5000),U23(5000), 2 U13(5000),U12(5000) COMMON/SCATFACTOR/GIS(142),GIW(142),NGP,NDIFF,ISOL,X0(3) COMMON/UNIT1/ITLE(80),LIST,PI CHARACTER ITLE DIMENSION G(142),CR(9) FP=4.0*PI IF (CR(1).LT.0.01) GO TO 15 WRITE (6,5) (CR(I),I=1,6) 5 FORMAT(36H GIVEN COORDINATES REFER TO THE CELL/2X,4H A =,F6.2, 1 2X,3HB =,F6.2,2X,3HC =,F6.2,2X,7HALPHA =,F6.1,2X,6HBETA =, 2 F6.1,2X,7HGAMMA =,F6.1) C CONVERT TO ORTHOGONAL COORDINATES CALL VOL(CR,V) R1=CR(3)*(CR(4)-CR(5)*CR(6))/CR(9) R2=CR(3)*V/CR(9) DO 10 I=NMEM,NTOT X(I)=CR(1)*X(I)+CR(2)*CR(6)*Y(I)+CR(3)*CR(5)*Z(I) Y(I)=CR(2)*CR(9)*Y(I)+R1*Z(I) Z(I)=R2*Z(I) 10 CONTINUE 15 D=1.0 DO 100 I=1,142 G(I)=0.0 T=0.01*FLOAT(I-1) TT=T*T DO 20 J=1,NK F(J)=AL(J)*EXP(-AS(J)*TT)+BL(J)*EXP(-BS(J)*TT)+CL(J)*EXP(-CS(J) 1 *TT)+DL(J)*EXP(-DS(J)*TT)+EL(J) 20 CONTINUE C SUM OVER INTERATOMIC VECTORS DO 50 K=NMEM,NTOT KT=NZ(K) NT=K+1 G(I)=G(I)+F(KT)*F(KT) IF (K.EQ.NTOT) GO TO 50 DO 40 L=NT,NTOT LT=NZ(L) IF (I.EQ.1) GO TO 30 D=FP*T*SQRT((X(K)-X(L))**2+(Y(K)-Y(L))**2+(Z(K)-Z(L))**2) D=SIN(D)/D 30 G(I)=G(I)+2.0*F(KT)*F(LT)*D 40 CONTINUE 50 CONTINUE G(I)=SQRT(G(I)) 100 CONTINUE WRITE (6,120) (G(I),I=1,101,2) 120 FORMAT(/1X,26X,'GROUP SCATTERING FACTORS AT INTERVALS OF 0.02 IN', 1 'SIN(THETA)/LAMBDA'/(1H ,17F7.2)) DO 140 I=1,142 GIS(I)=GIS(I)+G(I)*G(I)*POP 140 CONTINUE RETURN END ************************************************************************ * * * EEEEEEE CCCCC A L * * E C C A A L * * E C A A L * * EEEEE C A A L * * E C AAAAAAA L * * E C C A A L * * EEEEEEE CCCCC A A LLLLLLL * * * * CALCULATE FINAL E-VALUES AND RESCALED F'S * * OUTPUT REFLEXIONS FOR PHASE, PREPARE TABLES OF STATISTICS * * VERSION 1998 * ************************************************************************ SUBROUTINE ECAL COMMON/ATMGROUP/NINF(10),NAG(10),X(5000),Y(5000),Z(5000),NZ(5000), 1 Q(5000),U11(5000),U22(5000),U33(5000),U23(5000), 2 U13(5000),U12(5000) COMMON/REFLXIN/LH(600),LK(600),LL(600),FO(600),ID(600),RHO(600), 1 SIG(600),XKP(600) COMMON/REFLXOUT/IX(30000),EX(30000),FX(30000),SCMK(30000) COMMON/RESCALING/ISC,IBGR,MG,MIG(8),SCL,BT(9),SC(9),IP(8,3,5), 1 SCAL(8),RSTT COMMON/SCATFACTOR/GIS(142),GIW(142),NGP,NDIFF,ISOL,X0(3) COMMON/STATISTICS/VST(10,5),NST(5),ZT(25,5),EE(10),MULT,IND,NZR, 1 TMUL COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS COMMON/UNIT1/ITLE(80),LIST,PI,KCURV COMMON/WILSON/FLGW(30,9),FLGD(30,9),AVR(30,9),DCV(50,9),SLOPE(9), 1 FLGK(9),DEL(9),KS(9),EW(600),ED(600),EDP(600) COMMON/XXX/P(6),CX(9),NREF,NB,RHOMAX,MM,EMAX,EN,MZ,ER,ISIM,RHOCUT, 1 RHOMIN,RHOLOW,ENG(8),ERG(8),KNOWN,IPATH,VOLUME DIMENSION RHR(10),NHR(10),NU(25),STL(10),INP(600),NOB(600), 1 INPA(600),IXW(30000),EXW(30000),FXW(30000),EH(600) C TABLES OF THEORETICAL DISTRIBUTIONS CHARACTER ITLE,ICHR(80),IOBS,IUNOBS,NOB DIMENSION AVA(10),AVC(10),AVH(10) C DIMENSION CPH(25) DATA AVA/0.886, 1.0,1.329, 2.0,3.323, 6.0,0.736,1.0,2.0,2.415/ DATA AVC/0.798, 1.0,1.596, 3.0,6.383,15.0,0.968,2.0,8.0,8.691/ DATA AVH/0.718, 1.0,1.916,4.5,12.26,37.5,1.145,3.5,26.0,26.903/ C DATA CPH/0.368,0.463,0.526,0.574,0.612,0.643,0.670,0.694,0.715, C 1 0.733,0.765,0.791,0.813,0.832,0.848,0.863,0.875,0.886,0.896, C 2 0.905,0.913,0.920,0.926,0.932,0.938/ DATA IOBS,IUNOBS/1H ,1HU/ DATA ICHR/19*1H ,1HA,1HL,1HL,1H ,1HD,1HA,1HT,1HA,4*1H ,1HH,1HK, 1 1HL,4*1H ,1H0,1HK,1HL,17*1H ,1HA,1HC,1HE,1HN,1HT,1H ,1H ,1HC, 2 1HE,1HN,1HT,1H ,1H ,1HH,1H-,1HC,1HE,1HN,1HT,3*1H / C SET INITIAL VALUES IF (ISOL.EQ.1) MMS=MM IF (ISOL.EQ.1) MM=15000 DO 20 I=1,10 RHR(I)=0.0 NHR(I)=0 DO 10 J=1,5 VST(I,J)=0.0 10 CONTINUE 20 CONTINUE DO 40 I=1,5 NST(I)=0 DO 30 J=1,25 ZT(J,I)=0.0 30 CONTINUE 40 CONTINUE DO 50 I=1,25 NU(I)=0 50 CONTINUE NRW=0 LIM=30000 NC=0 NS=0 NL=0 IF (RSTT.GT.1.0) GO TO 54 IF (RSTT.GE.0.0) GO TO 53 MGW=0 DO 52 I=1,MG IF (MIG(I).EQ.-1) MGW=MGW+1 52 CONTINUE IF (MGW.EQ.0) GO TO 54 RSTT=FLOAT(MG-MGW)/FLOAT(MG) 53 LIMW=30000 NCW=0 NSW=0 NLW=0 ENW=EN ERW=ER MMW=INT(FLOAT(MM)*(1.0-RSTT)) MM=MM-MMW MZW=INT(FLOAT(MZ)*(1.0-RSTT)) MZ=MZ-MZW 54 KG=1 SCF=SQRT(SC(1)) RR=10.0/SQRT(RHOMAX) IF (LIST.EQ.1) WRITE (6,56) NREF 56 FORMAT(//1X,7HLIST OF,I5,1X,'REFLEXIONS.'/' F IS ON AN ABSOLUTE ', 1 'SCALE AND THE E-VALUES ARE SUITABLE FOR INPUT TO PHASE'/ 2 1X,1X,3(9H H K L,5X,1HF,4X,1HE,4X)) REWIND 8 60 READ (8) LH,LK,LL,FO,ID,EW,ED,RHO,SIG,EDP DO 250 I=1,600 IG=MOD(ID(I),100) IF (IBGR.EQ.1) KG=IG INPA(I)=32896 MF=I C TEST FOR END OF DATA IF (FO(I).LT.0.0) GO TO 300 D=EXP(BT(IG)*RHO(I)) D=D*SCAL(IG) MULT=ID(I)/10000 IE=(ID(I)-10000*MULT)/100 IF (KCURV.NE.1) ESQ=D*ED(I) IF (KCURV.EQ.1) CALL CURVK(ESQ,RHO(I),ED(I),KG) C CALCULATE E AND RESCALED F ED(I)=SQRT(ESQ) FO(I)=FO(I)*SCF C PACKING INPA(I)=65536*LH(I)+256*(LK(I)+128)+LL(I)+128 INP(I)=INPA(I)*32+ISIGN(1,INPA(I))*IG C SET OBS/UNOBS FLAG NOB(I)=IOBS IF (SIG(I).LT.0.0) NOB(I)=IUNOBS IF (SIG(I).GE.0.0 .AND. ED(I).LT.0.01) GO TO 110 IF (RHO(I).GT.RHOCUT) GO TO 110 IF (RHO(I).LT.RHOLOW) GO TO 110 C STORE REFLEXIONS FOR PHASE IF (RSTT.GT.1.0.OR.MIG(IG).GT.0) GO TO 85 IF (SIG(I).LT.0.0) GO TO 70 NLW=NLW+1 IF (ED(I).GT.ENW.AND.ED(I).LT.EMAX) GO TO 80 NLW=NLW-1 70 ED(I)=ED(I)+0.2*RHO(I) IF (ED(I).GT.ERW) GO TO 110 NSW=NSW+1 80 NCW=NCW+1 IXW(NCW)=INP(I) EXW(NCW)=ED(I) FXW(NCW)=FO(I) IF (NCW.NE.LIMW) GO TO 110 CALL SORT(EXW,FXW,IXW,30000) IF (MZW.GT.0) ERW=AMIN1(ERW,EXW(30001-MZW)) ENW=AMAX1(ENW,EXW(MMW)) NCW=MIN0(MMW,NLW) LIMW=30000-MZW GO TO 110 85 IF (SIG(I).LT.0.0) GO TO 90 NL=NL+1 IF (ED(I).GT.EN.AND.ED(I).LT.EMAX) GO TO 100 NL=NL-1 90 ED(I)=ED(I)+0.2*RHO(I) IF (ED(I).GT.ER) GO TO 110 NS=NS+1 100 NC=NC+1 IX(NC)=INP(I) EX(NC)=ED(I) FX(NC)=FO(I) IF (NC.NE.LIM) GO TO 110 CALL SORT(EX,FX,IX,30000) IF (MZ.GT.0) ER=AMIN1(ER,EX(30001-MZ)) EN=AMAX1(EN,EX(MM)) NC=MIN0(MM,NL) LIM=30000-MZ C WORK OUT FINAL STATISTICS 110 TMUL=FLOAT(MULT) C DISTRIBUTION OF E WITH SIN(THETA)/LAMBDA N=MIN0(10,INT(1.0+RR*SQRT(RHO(I)))) NHR(N)=NHR(N)+MULT RHR(N)=RHR(N)+ESQ*TMUL NZR=INT(10.0*ESQ)+1 IF (NZR.GT.10) NZR=10+(NZR-9)/2 EE(1)=ED(I) DO 120 J=2,6 EE(J)=EE(J-1)*ED(I) 120 CONTINUE EE(7)=ESQ-1.0 EE(8)=EE(7)*EE(7) EE(9)=EE(8)*EE(7) EE(10)=ABS(EE(9)) EE(7)=ABS(EE(7)) DO 130 J=1,10 EE(J)=TMUL*EE(J) 130 CONTINUE C ADD FUNCTIONS OF E TO APPROPRIATE ZONES IND=1 J=LH(I) K=LK(I) L=LL(I) CALL ADD(1) GO TO (140,140,140,150,160,160,170,180),KSYS C TRICLINIC, MONOCLINIC AND ORTHORHOMBIC 140 IF (J.EQ.0) CALL ADD(3) IF (K.EQ.0) CALL ADD(4) IF (L.EQ.0) CALL ADD(5) GO TO 200 C TETRAGONAL 150 IF (J.EQ.0.OR.K.EQ.0) CALL ADD(3) IF (IABS(J).EQ.IABS(K)) CALL ADD(4) IF (L.EQ.0) CALL ADD(5) GO TO 200 C TRIGONAL, HEXAGONAL AND RHOMBOHEDRAL INDEXED ON HEXAGONAL AXES 160 IF (J.EQ.0.OR.K.EQ.0.OR.J+K.EQ.0) CALL ADD(3) IF (J.EQ.K.OR.J+2*K.EQ.0.OR.2*J+K.EQ.0) CALL ADD(4) IF (L.EQ.0) CALL ADD(5) GO TO 200 C PRIMITIVE RHOMBOHEDRAL 170 IF (J.EQ.K.OR.J.EQ.L.OR.K.EQ.L) CALL ADD(3) IF (L.EQ.2*K-J.OR.K.EQ.2*J-L.OR.J.EQ.2*L-K) CALL ADD(4) IF (J+K+L.EQ.0) CALL ADD(5) GO TO 200 C CUBIC 180 IF (J.EQ.0.OR.K.EQ.0.OR.L.EQ.0) CALL ADD(3) IF (IABS(J).EQ.IABS(K).OR.IABS(J).EQ.IABS(L).OR. 1 IABS(K).EQ.IABS(L)) CALL ADD(4) C H,H,2H IS IN TWO PRINCIPAL ZONES BUT NOT ON A PRINCIPAL AXIS IF (IND.EQ.4) IND=0 IF (IABS(L).EQ.IABS(J+K).OR.IABS(K).EQ.IABS(J+L).OR. 1 IABS(J).EQ.IABS(K+L)) CALL ADD(5) C REFLEXIONS NOT BELONGING TO PRINCIPAL ZONES 200 IF (IND.EQ.1) CALL ADD(2) C DISTRIBUTION OF E FOR COMPLETE DATA NET=MIN0(25,INT(10.0*ED(I))) IF (NET.EQ.0) GO TO 220 NU(NET)=NU(NET)+1 220 NRW=NRW+MULT 250 CONTINUE 300 IF (FO(MF).LT.0.0) MF=MF-1 C LIST REFLEXIONS IF REQUIRED IF (LIST.EQ.1.AND.MF.NE.0) WRITE (6,306) (LH(K),LK(K),LL(K),FO(K), 1 ED(K),NOB(K),K=1,MF) C FORMAT FOR REFLEXION LIST - A WIDER LINEPRINTER MAY ALLOW MORE C REFLEXIONS TO BE OUTPUT ON ONE LINE - THUS SAVING PAPER 306 FORMAT(3(2H ,3I3,F7.1,F5.2,1X,A1)) C TEST FOR END OF DATA IF (MF.EQ.600) GO TO 60 C OUTPUT STATISTICS RR=1.0/RR DO 320 I=1,10 STL(I)=RR*FLOAT(I) IF (NHR(I).GT.0) RHR(I)=RHR(I)/FLOAT(NHR(I)) DO 310 J=1,5 IF (NST(J).GT.0) VST(I,J)=VST(I,J)/FLOAT(NST(J)) 310 CONTINUE 320 CONTINUE WRITE (6,330) STL,RHR,NHR 330 FORMAT(///1X,32X,16HFINAL STATISTICS//1H ,17X, 1 43HDISTRIBUTION OF E**2 WITH SIN(THETA)/LAMBDA/8H SIN/LAM, 2 F6.4,9F7.4/1H ,1X,4HE**2,2X,F6.4,9F7.4/1H ,6HNUMBER,10I7) WRITE (6,340) 340 FORMAT(//1X,32X,14HAVERAGE VALUES, 1 //1X,4X,7HAVERAGE,19X,'EXPERIMENTAL',19X,'THEORETICAL') IF (KSYS.LE.6) THEN ICHR(53)='H' ICHR(54)='K' ICHR(55)='0' IF (KSYS.LE.3) THEN ICHR(46)='H' ICHR(47)='0' ICHR(48)='L' ELSE ICHR(46)='H' ICHR(47)='H' ICHR(48)='L' ENDIF ELSE ICHR(50)='H' ICHR(51)=',' ICHR(52)='K' ICHR(53)=',' ICHR(54)='-' ICHR(55)='H' ICHR(56)='-' ICHR(57)='K' IF (KSYS.EQ.7) THEN ICHR(35)='H' ICHR(36)=',' ICHR(37)='K' ICHR(38)='2' ICHR(39)='K' ICHR(40)='-' ICHR(41)='H' ENDIF ENDIF WRITE (6,420) ICHR 420 FORMAT(80A1/) WRITE (6,430) ((VST(I,J),J=1,5),AVA(I),AVC(I),AVH(I),I=1,10) 430 FORMAT(1H ,5X,6HMOD(E),8X,8F7.3/ 1 1H ,6X,4HE**2,9X,8F7.3/ 2 1H ,6X,4HE**3,9X,8F7.3/ 3 1H ,6X,4HE**4,9X,8F7.3/ 4 1H ,6X,4HE**5,9X,8F7.3/ 5 1H ,6X,4HE**6,9X,8F7.3/ 6 1H ,2X,11HMOD(E**2-1),6X,8F7.3/ 7 1H ,2X,11H(E**2-1)**2,6X,8F7.3/ 8 1H ,2X,11H(E**2-1)**3,6X,8F7.3/ 9 1H ,16H(MOD(E**2-1))**3,3X,8F7.3) WRITE (6,440) NST 440 FORMAT(1X,20HWEIGHTED SAMPLE SIZE,I6,4I7) WRITE (6,520) 520 FORMAT(//18X,'DISTRIBUTION OF E - NUMBER OF ',14HE'S .GT. LIMIT) DO 540 I=1,25 AVR(I,IG)=0.1*FLOAT(I) II=I+1 IF (II.GT.25) GO TO 540 DO 530 J=II,25 NU(I)=NU(I)+NU(J) 530 CONTINUE 540 CONTINUE WRITE (6,542) (AVR(I,IG),I=7,16),(NU(I),I=7,16), 1 (AVR(I,IG),I=17,25),(NU(I),I=17,25) 542 FORMAT(1H ,7X,3HE ,10F6.1/1H ,6X,4HNO. ,10I6// 1 1H ,7X,3HE ,9F6.1,6X/1H ,6X,4HNO. ,9I6) C OUTPUT REFLEXIONS FOR PHASE MR=30000 IF (LIM.EQ.30000) MR=NC CALL SORT(EX,FX,IX,MR) MM=MIN0(MM,NL) MZ=MIN0(MZ,NS) IF (RSTT.GT.1.0.OR.RSTT.LT.0.0) GO TO 562 MRW=30000 IF (LIMW.EQ.30000) MRW=NCW CALL SORT(EXW,FXW,IXW,MRW) MMW=MIN0(MMW,NLW) MZW=MIN0(MZW,NSW) I1=MR-MZ DO 544 I=1,MZ I2=MM+I I3=I1+I IX(I2)=IX(I3) EX(I2)=EX(I3) FX(I2)=FX(I3) 544 CONTINUE I1=MM+MZ DO 546 I=1,MMW I2=I1+I IX(I2)=IXW(I) EX(I2)=EXW(I) FX(I2)=FXW(I) 546 CONTINUE I1=I1+MMW I2=MRW-MZW DO 548 I=1,MZW I3=I1+I I4=I2+I IX(I3)=IXW(I4) EX(I3)=EXW(I4) FX(I3)=FXW(I4) 548 CONTINUE MM=MM+MMW MZ=MZ+MZW MR=MM+MZ CALL SORT(EX,FX,IX,MR) 562 IF (ISOL.NE.1) GO TO 570 MMS=MIN0(MMS,MM) NF=0 DO 565 IGP=1,NGP NNS=NF+1 NF=NF+NAG(IGP) IF (NINF(IGP).NE.8) GO TO 565 CALL SOLENA(NNS,NF,MMS) GO TO 570 565 CONTINUE 570 WRITE (6,572) MM 572 FORMAT(///1H ,I6,41H LARGEST E-VALUES WRITTEN TO OUTPUT FILE) IF (RSTT.GT.1.0.OR.RSTT.LT.0.0) GO TO 580 MM2=MM-MMW WRITE (6,576) MM2 576 FORMAT(8X,10H(INCLUDING,I4,15H SYSTEMATICALLY, 1 20H STRONG REFLECTIONS)) MM2=MM-MMW 580 DO 583 I=1,MG SCAL(I)=SCAL(I)/SC(1) 583 CONTINUE CALL OUTPUT(0,MM) MS=MR-MZ WRITE (6,600) MZ 600 FORMAT(/1X,I6,42H SMALLEST E-VALUES WRITTEN TO OUTPUT FILE) IF (RSTT.GT.1.0.OR.RSTT.LT.0.0) GO TO 620 MZ2=MZ-MZW c WRITE (6,574) MZ2 IF (RSTT.GT.1.0.OR.RSTT.LT.0.0) GO TO 620 MZ2=MZ-MZW 620 CALL OUTPUT(MS,MR) RETURN END C -------- SUBROUTINE ADD(N) C SUMS FOR REFLEXION IN ZONE N COMMON/STATISTICS/VST(10,5),NST(5),ZT(25,5),EE(10),MULT,IND,NZR, 1 TMUL IS=1 NT=N IF (N.LE.2.OR.IND.LE.1) GO TO 20 C REFLEXION IS ON PRINCIPAL AXIS - THEREFORE IGNORE IT NT=IND IS=-1 20 S=FLOAT(IS) DO 30 I=1,10 VST(I,NT)=VST(I,NT)+S*EE(I) 30 CONTINUE NST(NT)=NST(NT)+IS*MULT IF (NZR.LE.25) ZT(NZR,NT)=ZT(NZR,NT)+S*TMUL IND=N RETURN END C ---------------- SUBROUTINE SORT(A,B,IX,N) C SORT ON A DIMENSION A(N),B(N),IX(N) INT=2 10 INT=2*INT IF (INT.LT.N) GO TO 10 INT=MIN0(N,(3*INT)/4-1) 20 INT=INT/2 IFIN=N-INT DO 70 II=1,IFIN I=II J=I+INT IF (A(I).GE.A(J)) GO TO 70 T=A(J) X=B(J) L=IX(J) 40 A(J)=A(I) B(J)=B(I) IX(J)=IX(I) J=I I=I-INT IF (I.LE.0) GO TO 60 IF (A(I).LT.T) GO TO 40 60 A(J)=T B(J)=X IX(J)=L 70 CONTINUE IF (INT.GT.1) GO TO 20 RETURN END ************************************************************************ * * * FFFFFFF CCCCC A L * * F C C A A L * * F C A A L * * FFFFF C A A L * * F C AAAAAAA L * * F C C A A L * * F CCCCC A A LLLLLLL * * * * CALCULATE RHO, EPSILON, MULTIPLICITY AND SCATTERING FACTOR * * CREATE THE SCRATCH FILE (CH.=8), PREPARE FILE FOR WEIGHTED FOURIER * * VERSION 1998 * ************************************************************************ SUBROUTINE FCAL COMMON/ATMGROUP/NINF(10),NAG(10),X(5000),Y(5000),Z(5000),NZ(5000), 1 Q(5000),U11(5000),U22(5000),U33(5000),U23(5000), 2 U13(5000),U12(5000) COMMON/REFLXIN/LH(600),LK(600),LL(600),FO(600),ID(600),RHO(600), 1 FC(600),XKP(600) COMMON/REFLXOUT/IX(30000),EX(30000),FX(30000),SCMK(30000) COMMON/RESCALING/ISC,IBGR,MG,MIG(8),SCL,BT(9),SC(9),IP(8,3,5), 1 SCAL(8) COMMON/SCATFACTOR/GIS(142),GIW(142),NGP,NDIFF,ISOL,X0(3) COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT COMMON/UNIT1/ ITLE(80),LIST,PI,KCURV,IPAT,IAPA,MOV,MFP,NAU COMMON/WILSON/FLGW(30,9),FLGD(30,9),AVR(30,9),DCV(50,9),SLOPE(9), 1 FLGK(9),DEL(9),KS(9),EW(600),ED(600),EDP(600) COMMON/XXX/P(6),CX(9),NREF,NB,RHOMAX,MM,EMAX,EN,MZ,ER,ISIM,RHOCUT, 1 RHOMIN,RHOLOW,ZCG(8),ZOG(8),KNOWN,IPATH,VOLUME,ZC,ZO DIMENSION I1(3),I2(3),AC(600),BC(600) CHARACTER ITLE DO 300 I=1,600 IF (FO(I).LT.0.0) GO TO 310 NREF=NREF+1 RHO(I)=P(1)*FLOAT(LH(I)*LH(I))+P(2)*FLOAT(LK(I)*LK(I)) 1 +P(3)*FLOAT(LL(I)*LL(I))+P(4)*FLOAT(LH(I)*LK(I)) 2 +P(5)*FLOAT(LH(I)*LL(I))+P(6)*FLOAT(LK(I)*LL(I)) RHOMAX=AMAX1(RHOMAX,RHO(I)) RHOMIN=AMIN1(RHOMIN,RHO(I)) C COMPUTE EPSILON AND MULTIPLICITY BY GENERATING EQUIVALENT C REFLEXIONS C EPSILON = NUMBER OF TIMES SAME REFLEXION APPEARS IN LIST C MULTIPLICITY = NUMBER DIFFERENT REFLEXIONS IN LIST EPS=1.0 MULT=1 I1(1)=LH(I) I1(2)=LK(I) I1(3)=LL(I) C IN TRICLINIC SPACE GROUPS EPS = 1.0 AND MULT = 1 IF (NSYM.EQ.1) GO TO 60 K1=65536*I1(1)+256*(I1(2)+128)+I1(3)+128 IK1=65792-K1 DO 50 J=2,NSYM DO 40 L=1,3 I2(L)=IS(L,1,J)*I1(1) + IS(L,2,J)*I1(2) + IS(L,3,J)*I1(3) 40 CONTINUE K2=65536*I2(1)+256*(I2(2)+128)+I2(3)+128 IF (K2.EQ.K1) EPS=EPS+1.0 IF (ICENT.NE.0.AND.K2.EQ.IK1) EPS=EPS+1.0 IF (K2.EQ.K1.OR.K2.EQ.IK1) MULT=MULT+1 50 CONTINUE 60 FF=FO(I)*FO(I)/PTS ID(I)=NSYM/MULT IF (ISC.EQ.2) GO TO 92 C DETERMINE INDEX GROUP (FOR RESCALING) MG=8 IF (KSYS.GT.3) MG=6 IF (KSYS.GE.7) GO TO 90 LG=MOD(IABS(LL(I)),2) IF (KSYS.GE.5) GO TO 80 KG=MOD(IABS(LK(I)),2) JG=MOD(IABS(LH(I)),2) C TRICLINIC, MONCLINIC AND ORTHORHOMBIC IF (KSYS.LE.3) IG=JG+2*KG+4*LG C TETRAGONAL IF (KSYS.EQ.4) IG=JG+KG+3*LG GO TO 100 C TRIGONAL, HEXAGONAL AND RHOMBOHEDRAL INDEXED ON HEXAGONAL AXES 80 IG=3*LG IF (MOD(LH(I),3).EQ.0) IG=IG+1 IF (MOD(LK(I),3).EQ.0.OR.MOD(LH(I)+LK(I),3).EQ.0) IG=IG+1 GO TO 100 C CUBIC AND PRIMITIVE RHOMBOHEDRAL 90 IG=3*MOD(IABS(LH(I)+LK(I)+LL(I)),2) IF (MOD(LH(I)-LL(I),3).EQ.0) IG=IG+1 IF (MOD(LK(I)-LL(I),3).EQ.0.OR.MOD(LH(I)-LK(I),3).EQ.0) IG=IG+1 GO TO 100 C DETERMINE INDEX GROUP FOR SPECIAL RESCALING 92 DO 98 J=1,MG DO 96 L=1,3 K=IABS(IP(J,L,1)*LH(I)+IP(J,L,2)*LK(I)+IP(J,L,3)*LL(I) 1 -IP(J,L,5)) IF (IP(J,L,4).EQ.0) GO TO 94 IF (MOD(K,IP(J,L,4)).NE.0) GO TO 98 GO TO 96 94 IF (K.NE.0) GO TO 98 96 CONTINUE IG=J-1 GO TO 100 98 CONTINUE IG=MG C PACK SYMMETRY FUNCTIONS FOR LATER USE 100 IG=IG+1 ID(I)=10000*ID(I)+100*INT(EPS+0.5)+IG C LOOK UP SCATTERING FACTOR TABLES GENERATED BY ATMCOEF SINTH=100.0*SQRT(RHO(I)) IND=MAX0(2,INT(SINTH+1.5)) FRAC=SINTH-FLOAT(IND-1) BF=0.5*(GIW(IND+1)-GIW(IND-1)) AF=BF+GIW(IND-1)-GIW(IND) WFORM=AF*FRAC*FRAC+BF*FRAC+GIW(IND) C 'WILSON' STRUCTURE FACTOR EW(I)=FF/(WFORM*EPS) ED(I)=EW(I) IF (KCURV.EQ.-1) ED(I)=FF BF=0.5*(GIS(IND+1)-GIS(IND-1)) AF=BF+GIS(IND-1)-GIS(IND) FORM=AF*FRAC*FRAC+BF*FRAC+GIS(IND) IF (KNOWN.EQ.1.OR.NDIFF.EQ.1) GO TO 105 C 'DEBYE' STRUCTURE FACTOR ED(I)=FF/(FORM*EPS) IF (KCURV.EQ.-1) ED(I)=FF GO TO 300 105 NS=1 C PHASES FOR WEIGHTED F-MAP DO 110 IGP=1,NGP NF=NS+NAG(IGP)-1 IF (NINF(IGP).EQ.4.OR.NINF(IGP).EQ.6.OR.NINF(IGP).EQ.7) GO TO 120 NS=NF+1 110 CONTINUE 120 AC(I)=0.0 BC(I)=0.0 IENT=0 DO 160 J=1,NSYM T=1000.0 DO 150 L=1,3 T=T+FLOAT(I1(L))*TS(L,J) I2(L)=IS(L,1,J)*I1(1) + IS(L,2,J)*I1(2) + IS(L,3,J)*I1(3) 150 CONTINUE CALL SFAC(NS,NF,I2,T,RHO(I),A,B,IENT) IENT=1 AC(I)=AC(I)+A IF (ICENT.EQ.0) BC(I)=BC(I)+B IF (ICENT.EQ.1) AC(I)=AC(I)+A 160 CONTINUE IIG=1 IF (IBGR.EQ.1) IIG=MG+1 FCL=PTS*SQRT(AC(I)*AC(I)+BC(I)*BC(I)) IF (NINF(IGP).EQ.4) EDP(I)=FF/(FCL**2/PTS+FORM*EPS) IF (SC(1).LT.0.0001) SC(1)=1.0 IF (FORM.LT.0.001) ISIM=0 IF (ISIM.EQ.1) 1 XKP(I) = 2.0*SC(1)*EXP(-BT(IIG)*RHO(I))*FCL/FORM/EPS/PTS FC(I)=FCL*EXP(-BT(IIG)*RHO(I)) FO(I)=SC(1)*FO(I) ZC=ZC+FC(I) ZO=ZO+FO(I) ZCG(IG)=ZCG(IG)+FC(I) ZOG(IG)=ZOG(IG)+FO(I) 300 CONTINUE I=600 C CREATE SCRATCH FILE 310 IF (NDIFF.EQ.0) WRITE (8) LH,LK,LL,FO,ID,EW,ED,RHO,FC,EDP C CREATE FILE FOR WEIGHTED FOURIER IF (FO(I).LT.0.0) LH(I)=-1000 IF (NDIFF.EQ.1) THEN WRITE (2) LH,LK,LL,AC,BC,FO,FC,ID,RHO,XKP WRITE (8) LH,LK,LL,AC,BC,FO,FC,ID,RHO,XKP ENDIF RETURN END C ------------------ C BESSEL FUNCTION I1(X)/I0(X) FUNCTION BS10(X) REAL*8 Y,P1,P2,P3,P4,P5,P6,P7,Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9, 1 R1,R2,R3,R4,R5,R6,R7,S1,S2,S3,S4,S5,S6,S7,S8,S9 DATA P1,P2,P3,P4,P5,P6,P7/1.0D0,3.5156229D0,3.0899424D0, 1 1.2067492D0,0.2659732D0,0.360768D-1,0.45813D-2/, 2 Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9/0.39894228D0,0.1328592D-1, 3 0.225319D-2,-0.157565D-2,0.916281D-2,-0.2057706D-1, 4 0.2635537D-1,-0.1647633D-1,0.392377D-2/, 5 R1,R2,R3,R4,R5,R6,R7/0.5D0,0.87890594D0,0.51498869D0, 6 0.15084934D0,0.2658733D-1,0.301532D-2,0.32411D-3/, 7 S1,S2,S3,S4,S5,S6,S7,S8,S9/0.39894228D0,-0.3988024D-1, 8 -0.362018D-2,0.163801D-2,-0.1031555D-1,0.2282967D-1, 9 -0.2895312D-1,0.1787654D-1,-0.420059D-2/ IF (ABS(X).LT.3.75) THEN Y=(X/3.75)**2 BS10=X*(R1+Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*(R6+Y*R7)))))) 1 /(P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7)))))) ELSE Y=3.75/ABS(X) BS10=(S1+Y*(S2+Y*(S3+Y*(S4+Y*(S5+Y*(S6+Y*(S7+Y*(S8+Y*S9)))))))) 1 /(Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9)))))))) ENDIF RETURN END C----------------------------------------------------------------------- SUBROUTINE INCELL C INPUT UNIT CELL PARAMETERS AND CALCULATE RECIPROCAL PARAMETERS COMMON/UNIT1/ITLE(80),LIST,PI COMMON/XXX/P(6),CX(9),NREF,NB,RHOMAX,MM,EMAX,EN,MZ,ER,ISIM,RHOCUT, 1 RHOMIN,RHOLOW,ENG(8),ERG(8),KNOWN,IPATH,VOLUME CHARACTER ITLE WRITE (6,20) (CX(I),I=1,6) 20 FORMAT(/1X,10HUNIT CELL:,7X,3HA =,F8.3,7X,3HB =,F8.3,7X, 1 3HC =,F8.3/14X,7HALPHA =,F7.2,5X,6HBETA =,F7.2,4X,7HGAMMA =,F7.2) CALL VOL(CX,V) C VOLUME AND RECIPROCAL CELL FUNCTIONS V=1.0/(V*CX(1)*CX(2)*CX(3)) VOLUME=1.0/V P(1)=CX(2)*CX(3)*CX(7)*V P(2)=CX(1)*CX(3)*CX(8)*V P(3)=CX(1)*CX(2)*CX(9)*V P(4)=0.5*P(1)*P(2)*(CX(4)*CX(5)-CX(6))/(CX(7)*CX(8)) P(5)=0.5*P(1)*P(3)*(CX(4)*CX(6)-CX(5))/(CX(7)*CX(9)) P(6)=0.5*P(2)*P(3)*(CX(5)*CX(6)-CX(4))/(CX(8)*CX(9)) DO 40 I=1,3 P(I)=0.25*P(I)*P(I) CX(I+3)=180.0*ATAN2(CX(I+6),CX(I+3))/PI 40 CONTINUE C WRITE (6,50) P C 50 FORMAT(/1X,23H(SIN(THETA)/LAMBDA)**2=, C 1 F8.6,9H * H**2 +,F9.6,9H * K**2 +,F9.6,9H * L**2 +, C 2 /24X,F8.6,10H * H * K +,F8.6,10H * H * L +,F8.6,8H * K * L/) RETURN END ************************************************************************ * * * IIIIIII N N PPPPPP U U TTTTTTT * * I NN N P P U U T * * I N N N P P U U T * * I N N N PPPPPP U U T * * I N N N P U U T * * I N NN P U U T * * IIIIIII N N P UUUUU T * * * * FREE FORMAT DATA INPUT * * VERSION 1998 * ************************************************************************ SUBROUTINE INPUT_P(JUMP,NON,MISS,KMARK,NTOTAL,BTT) COMMON/ATMFACTOR/AL(8),AS(8),BL(8),BS(8),CL(8),CS(8),DL(8),DS(8), 1 EL(8),NW(8),NO(8),NK,NAT,F(9) COMMON/ATMGROUP/NINF(10),NAG(10),X(5000),Y(5000),Z(5000),NZ(5000), 1 Q(5000),U11(5000),U22(5000),U33(5000),U23(5000), 2 U13(5000),U12(5000) COMMON/REFLXIN/LH(600),LK(600),LL(600),FO(600),ID(600),RHO(600), 1 SIG(600),XKP(600) COMMON/RESCALING/ISC,IBGR,MG,MIG(8),SCL,BT(9),SC(9),IP(8,3,5), 1 SCAL(8),RSTT COMMON/SCATFACTOR/GIS(142),GIW(142),NGP,NDIFF,ISOL,X0(3) COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT, 1 IAVE,EXTI COMMON/UNIT1/ ITLE(80),LIST,PI,KCURV,IPAT,IAPA,MOV,MFP,NAU COMMON/XXX/P(6),CX(9),NREF,NB,RHOMAX,MM,EMAX,EN,MZ,ER,ISIM,RHOCUT, 1 RHOMIN,RHOLOW,ENG(8),ERG(8),KNOWN,IPATH,VOLUME DIMENSION POP(10),NA(8),CR(9,10),VECT(8,3),X00(120) DIMENSION ICONV(7500),WTFOM(3),KEYWRD(93) DIMENSION IDIV(20),IB(20),MARKNO(98) CHARACTER N(80),LETT(26),KX(10),KSP,KM,KD,KEQ,KP,KSC,ITERM(4), 1 NGS(26),M(80),ITLE,lett1(26) real cellp(6) DATA LETT/1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,1HK,1HL,1HM, 1 1HN,1HO,1HP,1HQ,1HR,1HS,1HT,1HU,1HV,1HW,1HX,1HY,1HZ/ DATA LETT1/1Ha,1Hb,1Hc,1Hd,1He,1Hf,1Hg,1Hh,1Hi,1Hj,1Hk,1Hl,1Hm, 1 1Hn,1Ho,1Hp,1Hq,1Hr,1Hs,1Ht,1Hu,1Hv,1Hw,1Hx,1Hy,1Hz/ DATA KX/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/ DATA KSP/1H /,KM/1H-/,KD/1H./ DATA KEQ/1H=/,KP/1H+/,KSC/1H;/ DATA ITERM/1HH,1HK,1HL,1HN/ DATA IOFR/0/,MKREJ/1/,ISTO/0/,NOJOIN/0/,ITAN/0/,NANY/0/,KMIN/60/, 1IPATH/0/,NDET/0/,LSTP/-1/,METAL/0/,PROB/1.01/,ISTAGE/1/, NGEN/0/, 2 NSPEC/0/,NINPUT/0/,IMKK/0/,IFOM/1/,KMAX/5000/,MN/0/,IPUB/0/, 3 ISKIP/0/, CUT1/1.8/,CUT2/1.6/,WTFOM/0.2,1.4,1.4/,NOSET/0/, 6 GRID/0.28/,IWMIN/25/,NRAN/250/,ANGMI/85.0/,ANGMA/145.0/, 7 DMIN/1.1/, DMAX/1.95/,DMUT/2.4/,DM/0.85/,IWT/2/,NAA/0/,MFRN/0/, 8 NPK/0/,NSREQ/0/,DFRG/2.8/,IHAR/0/, NHAR/0/,NHV/0/ DATA KEYWRD 1 /1000, 2000, 3000, 10219, 10321, 11220, 11301, 11309, 11601, 2 12015, 12205, 20321, 20601, 20718, 30512, 30815, 31514, 32220, 3 40520, 40615, 41301, 41309, 41521, 50613, 50914, 51301, 51309, 4 51401, 51619, 51917, 60103, 60119, 60918, 70514, 71809, 71815, 5 80118,110118,110321,111301,111309,111415,120119,120913,120919, 6 130124,130520,130919,131512,131522,132112,140121,140801,140822, 7 141510,141513,141518,141623,141801,141805,142618,151806,151809, 8 151814,160119,160120,160501,160513,160519,160801,161220,161519, 9 161613,161619,161815,161909,180114,180519,180815,181903,181920, * 190301,190520,191109,191512,191605,191620,192015,192320,211423, * 230615,231309,120102/ CALL CCPDPN(7,'SCRA7.TM','SCRATCH','F',80,0) c OPEN(7,FILE='SCRA.TM',FORM='FORMATTED',STATUS='UNKNOWN') C NAME OF THE WHOLE PACKAGE, TO BE PRINTED OUT ONLY WITH JOB REMARKS 10 FORMAT(////// &60H SSSSSSSS AA PPPPPPPPP II / &60H SSSSSSSSSS AAAA PPPPPPPPPP II / &60H SS SS AA AA PP PP II / &60H SS AA AA PP PP II 9999 55555 / &60H SSSSSSSSS AA AA PPPPPPPPPP II 9 9 5 / &60H SSSSSSSSS AA AA PPPPPPPPP II 9 9 5 / &60H SS AAAAAAAAAA PP II === 99999 55555 / &60H SS SS AAAAAAAAAA PP II 9 5 / &60H SSSSSSSSSS AA AA PP II 9 9 5 5 / &60H SSSSSSSS AA AA PP II 9999 5555 / &/////) KUSER3=15000 C SET INITIAL AND DEFAULT VALUES IVAE=0 NHAF=0 MISS=0 DO 12 I=1,120 12 X00(I)=0.0 DO 20 I=1,7500 ICONV(I)=0 IF (I.GT.5000) GO TO 20 X(I)=0.0 Y(I)=0.0 Z(I)=0.0 Q(I)=1.0 U11(I)=0.0 U22(I)=0.0 U33(I)=0.0 U23(I)=0.0 U13(I)=0.0 U12(I)=0.0 IF (I.GT.98) GO TO 20 MARKNO(I)=0 IF (I.GT.20) GO TO 20 IB(I)=0 IDIV(I)=0 IF (I.GT.10) GO TO 20 NINF(I)=0 DO 14 J=1,9 CR(J,I)=0.0 14 CONTINUE IF (I.GT.8) GO TO 20 MIG(I)=1 AL(I)=0.000 AS(I)=0.000 BL(I)=0.000 BS(I)=0.000 CL(I)=0.000 CS(I)=0.000 DL(I)=0.000 DS(I)=0.000 EL(I)=0.000 SCAL(I)=0.0 SC(I)=-1.0 NW(I)=0 NO(I)=0 BT(I)=-200.0 DO 16 J=1,3 VECT(I,J)=0.0 DO 16 K=1,5 IP(I,J,K)=0 16 CONTINUE 20 CONTINUE C DEFAULT UNIT CELL CONTENT: C ATOM --- CARBON. THE NUMBER OF WHICH IS TO BE ESTIMATED C ACCORDING TO THE VOLUME OF UNIT CELL KMARK=0 NK=1 NW(1)=3 NA(1)=-100 JUMP=-1 ITPR=0 NON=0 IND=1 IFAST=0 ISOL=0 MM=0 MG=0 NB=0 KCURV=0 MZ=100 LIST=0 IBGR=0 NTOT=0 NAU=0 ISC=1 NGP=0 NSYM=1 ISIM=1 C -- 3A CUTOFF RHOCUT=0.0278 RHOLOW=0.0 EMAX=5.0 EN=1.2 ER=0.3 SCL=0.5 IPAT=0 MOV=0 MFP=10 IAPA=0 NAPA=0 RSTT=-1.0 NSYM = 1 pts = 1 ICENT = 0 C -- flag latt = 0 cx(1) = 0.0 80 KS=1 MEQ=0 READ (10,90) N 90 FORMAT(80A1) 100 KEY=0 IKW=0 IC=0 IMK=0 IM=1 IGG=0 110 DO 200 I=KS,80 DO 120 K=1,26 IF (LETT(K).EQ.N(I).or.lett1(k).eq.n(i)) GO TO 190 120 CONTINUE IF (IKW.EQ.0) GO TO 200 IF (IKW.LT.3.AND.N(I).EQ.KSP) GO TO 185 IF (IKW.LT.3) GO TO 6000 IF (IC.GT.20) GO TO 200 DO 130 K=1,10 IF (KX(K).EQ.N(I)) GO TO 180 130 CONTINUE IF (N(I).EQ.KD) GO TO 170 IF (N(I).EQ.KM) GO TO 150 IM=1 IF (N(I).EQ.KSP) GO TO 160 IF (N(I).EQ.KSC) GO TO 160 IF (N(I).EQ.KEQ) GO TO 140 IF (N(I).EQ.KP) GO TO 167 GO TO 6000 140 MEQ=MEQ+1 GO TO 167 150 IM=-1 160 IF (IMK.LE.0) IC=IC+1 IF (IC.GT.20) GO TO 200 IF (IC.LE.2) GO TO 167 C (GRO) INDEX GROUP SPECIFICATION IF (KEY.NE.71815) GO TO 167 DO 162 KK=1,4 IF (ITERM(KK).EQ.N(I-1)) GO TO 165 162 CONTINUE IP(MI,MJ,5)=IB(2) 165 IC=2 167 IB(IC)=0 IDIV(IC)=0 IMK=1 GO TO 200 170 IMK=-1 GO TO 200 180 IB(IC)=IM*(10*IABS(IB(IC))+K-1) IF (IMK.EQ.1) IMK=0 IF (IMK.LT.0) IDIV(IC)=IDIV(IC)-1 IF (I.EQ.80) GO TO 181 IF (N(I+1).NE.KSP) GO TO 200 C TEST FOR REMARKS (180513=rem) 181 IF (KEY.EQ.180513) GO TO 300 c (160801=pha, 190520=set, 12015=ato, 131512=mol) IF (KEY.EQ.160801.OR.KEY.EQ.190520.OR.KEY.EQ.12015.OR. 1 KEY.EQ.131512) GO TO 210 c (111415=kno, 161613=ppm, 160513=pem, 160519=pes, 161619=pps c 140822=nhv THREE PARAMETERS (x y z coordinates ) WILL c FOLLOW THOSE KEYWORDS) IF (KEY.EQ.111415.OR.KEY.EQ.161613.OR.KEY.EQ.160513.OR. 1 KEY.EQ.160519.OR.KEY.EQ.161619.OR.KEY.EQ.140822) GO TO 182 NREC=IC IF (IC.NE.20) GO TO 200 IGG=1 KS=I+1 IF (KS.GT.80) THEN KS=1 READ (10,90) N ENDIF IC=0 GO TO 220 182 NREC=IC IF (IC.NE.18) GO TO 200 IGG=1 KS=I+1 IF (KS.GT.80) THEN KS=1 READ (10,90) N ENDIF IC=0 GO TO 220 185 GO TO (6000,6000,2100,2200,2300),IND 190 IF (IC.LE.1.AND.IGG.EQ.1) GO TO 192 IGG=0 IF (IC.GT.0) GO TO 210 GO TO 195 192 KS=I GO TO 100 195 IF (IKW.GE.3) GO TO 200 IKW=IKW+1 KEY=100*KEY+K IF (IKW.LT.3) GO TO 200 C TEST FOR END OF KEYWORD FILE IF (KEY.EQ.51404) GO TO 2800 C (REMARK) IF (KEY.EQ.180513.OR.ITPR.EQ.1) GO TO 197 C PRINT TITLE WRITE (6,360) ITLE ITPR=1 C (SPACE GROUP: SPG) 197 IF (KEY.EQ.191607) GO TO 1630 200 CONTINUE C GRO IF (KEY.EQ.71815) GO TO 80 KS=1 READ (10,90) N GO TO 110 210 KS=I 220 DO 250 II=1,93 IF (KEY.NE.KEYWRD(II)) GO TO 250 GO TO (2150,2250,2350, 400, 420, 430, 440, 450, 465, 2 470, 485, 490, 500, 600, 610, 620, 630, 685, 690, 3 700, 710, 720, 730, 750, 760, 765, 770, 780, 4 790, 800, 810, 820, 830, 840, 850, 860, 887, 5 890, 900, 910, 920, 930, 940, 955, 960, 980, 6 1200,1205,1210,1220,1240,1250,1253,1255,1270, 7 1290,1300,1310,1320,1330,1340,1350,1360,1370, 8 1380,1390,1395,1400,1408,1410,1440,1445,1447, 9 1449,1460,1470,1480,1490,1550,1560,1570,1575, * 1590,1600,1610,1620,1650,1660,1670,1680,1690, * 1700,80), II 250 CONTINUE GO TO 6000 300 WRITE (6,10) ITPR=1 IREM=IB(1) DO 340 I=1,IREM READ (10,90) N WRITE (6,330) N 330 FORMAT(50X,80A1) 340 CONTINUE C PRINT JOB TITLE WRITE (6,360) ITLE 360 FORMAT(1X,'PRELIMINARY PROCESSING OF INPUT ', 1 'DATA'//80A1) GO TO 80 C *** KEYWORD PROCESSING *** C *ABS* ABSFOM WEIGHT 400 WTFOM(1) = FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *ACU* INITIAL CUTOFF OF THE FIRST EARLY FIGURE OF MERIT 420 CUT1 = FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *ALT* LIST A FULL CONVERGENCE MAP 430 LSTP = 1 GO TO 100 C *AMA* MAXIMUM ALLOWED BOND ANGLE 440 ANGMA=FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *AMI* MINIMUM ALLOWED BOND ANGLE 450 ANGMI=FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *APA* AUTOMATIC PATTERSON ANALYSIS 465 NAPA = 1 ISTO=1 GO TO 100 C *ATO* ADDITIONAL ATOMS TO BE CONSIDERED IN "SEARCH" 470 NAA = IB(1) DO 480 I=1,NAA READ (10,90) N WRITE (7,90) N 480 CONTINUE GO TO 80 C *AVE* DATA AVERAGE 485 IAVE=1 GO TO 100 C *BCU* SECOND CUTOFF OF THE EARLY FIGURE OF MERIT 490 CUT2 = FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *BFA* B-FACTOR 500 BTT=0.0 DO 505 J=1,8 IF (J.LT.IC) BT(J)=FLOAT(IB(J))*10.0**IDIV(J) 505 CONTINUE IC1=IC-1 IF (IC1.EQ.1) BTT=BT(1) IF (IC1.GT.1.AND.ISC.EQ.1) ISC=0 JUMP=JUMP+1 GO TO 100 C *BGR* WILSON PLOT FOR EACH REFLECTION GROUPS 600 IBGR=1 NAU=1 GO TO 100 C *CEL* CELL DIMENSIONS 610 IF (IC.NE.7) GO TO 6000 DO 615 J=1,6 IF (NGP.EQ.0) CX(J)=FLOAT(IB(J))*10.0**IDIV(J) IF (NGP.GT.0) CR(J,NGP)=FLOAT(IB(J))*10.0**IDIV(J) 615 CONTINUE IF (NGP.EQ.0) CALL INCELL IF (NA(1).LT.0) NA(1)=VOLUME*0.06023/400. GO TO 100 C *CHO* PHASE-SET NUMBER CHOSEN FOR GENERATING AN E-MAP 620 NOSET = IB(1) GO TO 100 C *CON* CONTENTS OF THE UNIT CELL 630 NK=0 IND=3 GO TO 100 C *CVT* CONVENTIONAL WEIGHTED TANGENT REFINMENT 685 ITAN = 2 GO TO 100 C *DET* NUMBER OF PHASES TO BE DETERMINED 690 NDET = IB(1) GO TO 100 C *DFO* DIFFERENCE FOURIER 700 IND=7 ISTO = 1 GO TO 1710 C *DMA* MAXIMUM ALLOWED BOND LENGTH 710 DMAX=FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *DMI* MINIMUM ALLOWED BOND LENGTH 720 DMIN=FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *DOU* MAXIMUM INTERPEAK DISTANCE TO BE TABULATED 730 DMUT=FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *EFM* EARLY FIGURE OF MERIT IN "PHASE" WILL BE USED 750 IFOM = 0 GO TO 100 C *EIN* E VALUES INSTEAD OF F(OBS) ARE USED AS DIFFRACTION DATA 760 BT(1)=0.0 SCAL(1)=1.0 KCURV=-1 JUMP=1 GO TO 100 C *EMA* MAXIMUM VALUE OF LARGEST E'S PASSED TO "PHASE" 765 EMAX=FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *EMI* MINIMUM VALUE OF LARGEST E'S PASSED TO "PHASE" 770 EN=FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *ENA* ENANTIOMORPH FIXING REFLECTION 780 IEND = IC-1 DO 785 II=1,IEND NINPUT = NINPUT + 1 IF (NINPUT.GT.7500) GO TO 1720 ICONV(NINPUT) = IB(II) * 1000000 + 300 785 CONTINUE GO TO 100 C *EPS* MAXIMUM VALUE OF PSI(ZERO) E'S PASSED TO "PHASE" 790 ER=FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *ESQ* UPPER LIMIT OF FOR 'WEAK' REFLECTION GROUPS 800 SCL=FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *FAC* ANALYTICAL CONSTANTS OF ATOMIC SCATTERING FACTORS 810 IND=5 GO TO 100 C *FAS* RUNNING THE WHOLE JOB IN A FAST WAY 820 IFAST=1 NRAN=100 NAU=1 GO TO 100 C *FIR* RUN THE FIRST PART OF "PHASE" 830 IPATH = 1 GO TO 100 C *GEN* NUMBER OF GENERAL REFLECTIONS IN STARTING SET 840 NGEN = IB(1) GO TO 100 C *GRI* GRID SPACING USED IN "EXFFT" 850 GRID=FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *GRO* INDEX GROUP SPECIFICATION 860 MI=IB(1) MJ=MEQ IF (IB(IC).EQ.0) IB(IC)=IM DO 865 K=1,4 IF (ITERM(K).EQ.N(I)) GO TO 870 865 CONTINUE 870 IF (K.LE.3) MJ=MJ+1 IP(MI,MJ,K)=IB(IC) KS=KS+1 GO TO 110 C *HAR* TEST FOR HARKER ANALYSIS 887 IAPA=IAPA+1 ISTO=1 IF (IB(1).EQ.0) GO TO 100 C IHAR --- NUMBER OF HARKER PEAKS IHAR=IB(1) GO TO 100 C *KAR* KARLE RECYCLING 890 KMARK=IB(1) IND=5 ITAN=1 NRAN=500 IWMIN=45 GO TO 1710 C *KCU* K-CURVE NORMALIZATION 900 KCURV=1 GO TO 100 C *KMA* MAXIMUM KAPPA-VALUE ACCEPTED IN "PHASE" 910 KMAX = INT(100.0*FLOAT(IB(1))*10.0**IDIV(1)) GO TO 100 C *KMI* MINIMUM KAPPA-VALUE ACCEPTED IN "PHASE" 920 KMIN = INT(100.0*FLOAT(IB(1))*10.0**IDIV(1)) GO TO 100 C *KNO* KNOWN PHASES 930 DO 935 II=1,NREC,3 NINPUT = NINPUT + 1 IF (NINPUT.GT.7500) GO TO 1720 IPACK = IB(II) * 1000000 C READ PHASE IPACK = IPACK + IB(II+1) * 1000 C READ WEIGHT ICONV(NINPUT) = IPACK + IB(II+2) 935 CONTINUE IF (IGG.EQ.1) GO TO 110 GO TO 100 C *LAS* RUN THE LAST PART OF PHASE 940 IPATH = 2 NON = 1 GO TO 100 C *LIM* RESOLUTION LIMIT FOR REFLECTIONS TO BE ACCEPTED(ANGSTROM) 955 ANSTR1=FLOAT(IB(1))*10.0**IDIV(1) ANSTR2=FLOAT(IB(2))*10.0**IDIV(2) RHOLOW=1/(4*ANSTR1*ANSTR1) RHOCUT=1/(4*ANSTR2*ANSTR2) GO TO 100 C *LIS* LIST ALL F(OBS) AND E'S 960 LIST=1 GO TO 100 C *MAX* MAXIMUM NUMBER OF PHASE SETS TO BE GENERATED 980 NSREQ = IB(1) GO TO 100 C *MET* NUMBER OF HEAVY ATOMS TO BE CONSIDERED IN "SEARCH" 1200 METAL=IB(1) GO TO 100 C *MIS* COMPENSATION OF THE MISSING REFLECTIONS FOR WILSON STAT. 1205 MISS=1 GO TO 100 C *MOL* SPECIFYING MOLECULAR CONNECTIVITY FOR "SEARCH" 1210 MFRN=IB(1) DO 1215 I=1,MFRN READ (10,90) N WRITE (7,90) N 1215 CONTINUE GO TO 80 C *MOV* REMOVING PATTERSON ORIGIN 1220 MOV=1 GO TO 100 C *MUL* MULTIPLICITY C NUMBER OF TIMES THE RONDOM GROUP APPEARS IN THE UNIT CELL 1240 POP(NGP)=FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *NAU* BY-PASS THE SUBROUTINE "AUTOGP" 1250 NAU=1 GO TO 100 C *NHA* TEST FOR NON-HARKER ANALYSIS 1253 IAPA=IAPA+2 ISTO=1 C NHAR -- NUMBER OF NON-HARKER PEAKS IF (IB(1).EQ.0) GO TO 100 NHAR=IB(1) GO TO 100 C *NHV* NUMBER OF HEAVY ATOMS USED FOR NON-HARKER ANALYSIS 1255 II=NREC/3 IF (II.EQ.0) GO TO 1257 DO 1256 J=1,II NHAF=NHAF+1 IF (NHAF.GT.40) GO TO 6000 K=(NHAF-1)*3 X00(K+1)=FLOAT(IB(K+1))*10.0**IDIV(K+1) X00(K+2)=FLOAT(IB(K+2))*10.0**IDIV(K+2) X00(K+3)=FLOAT(IB(K+3))*10.0**IDIV(K+3) 1256 CONTINUE IF (IGG.EQ.1) GO TO 110 NHV=NHAF GO TO 100 1257 IF (IB(1).GT.40) GO TO 6000 NHV=IB(1) GO TO 100 C *NOJ* NO INTERPRETATION OF PEAK CONNECTIVITY SHOULD BE MADE 1270 NOJOIN=1 GO TO 100 C *NOM* NO MODIFICATION ON RUNNING "PHASE" DISREGARDING WHETHER C THE STRUCTURE CONTAINS PSEUDO-TRANSLATIONAL SYMMETRY 1290 ISTAGE = 0 GO TO 100 C *NOR* NO REJECTING OF 'W-W-W' PHASE RELATIONSHIPS 1300 MKREJ=0 GO TO 100 C *NPW* NUMBER OF POINTS ON WILSON PLOT 1310 NB=IB(1) GO TO 100 C *NRA* NUMBER OF REFLECTIONS IN STARTING SET OF "PHASE" 1320 NRAN = IB(1) GO TO 100 C *NRE* NUMBER OF LARGEST E'S PASSED TO "PHASE" 1330 MM=IB(1) GO TO 100 C *NZR* NUMBER OF PSI-ZERO REFLECTIONS PASSED TO "PHASE" 1340 MZ=IB(1) GO TO 100 C *ORF* FREE OF ORIGIN FIXATION 1350 IOFR=1 GO TO 100 C *ORI* ORIENTED MOLECULAR GROUP 1360 IND=3 GO TO 1710 C *ORN* CODES OF ORIGIN FIXING REFLECTIONS 1370 IEND = IC-1 DO 1375 II=1,IEND NINPUT = NINPUT + 1 IF (NINPUT.GT.7500) GO TO 1720 ICONV(NINPUT) = IB(II) * 1000000 + 200 1375 CONTINUE GO TO 100 C *PAS* BY-PASS "PREPAR" AFTER KEYWORDS HAVE BEEN INPUT 1380 NON=1 GO TO 100 C *PAT* PATTERSON 1390 IPAT=2 IF (N(I).EQ.LETT(6).AND.N(I+1).EQ.LETT(6)) IPAT=1 IF (N(I).EQ.LETT(5).AND.N(I+1).EQ.LETT(5)) IPAT=3 KS=I+2 ISTO=1 GO TO 100 C *PEA* NUMBER OF PEAKS TO BE SEARCHED FOR IN THE DENSITY MAP 1395 NPK=IB(1) GO TO 100 C *PEM* MINIMUM FUNCTION OF PATTERSON-MAP AND E-MAP 1400 MFP = 1 1401 ISTO = 1 II=NREC/3 IF (II.EQ.0.AND.MN.EQ.0) GO TO 1403 IF (II.EQ.0) GO TO 6000 DO 1402 J=1,II MN = MN+1 IF (MN.GT.8) GO TO 6000 DO 1402 JJ=1,3 K=(J-1)*3+JJ VECT(MN,JJ)=FLOAT(IB(K))*10.0**IDIV(K) 1402 CONTINUE IF (IGG.EQ.1) GO TO 110 GO TO 100 1403 MN=IB(1) IF (MN.GT.8) GO TO 6000 CALL CCPDPN(15,'SAPIPKS','UNKNOWN','F',80,0) c OPEN(15,FILE='SAPI95.PKS',FORM='FORMATTED',STATUS='UNKNOWN') READ (15,90) M DO 1405 J=1,MN READ (15,1406) (VECT(J,JJ),JJ=1,3) 1405 CONTINUE 1406 FORMAT(5X,3F10.4) CLOSE (15) GO TO 100 C *PES* SUM FUNCTION OF E-MAP AND PATTERSON MAP 1408 MFP=3 GOTO 1401 C *PHA* STARTING PHASES IN A SINGLE RUN OF TANGENT REFINEMENT 1410 IMKK=IB(1) IMKMAX=KUSER3/2 IF (IMKK .GT. IMKMAX) GO TO 1430 IF (IMKK.EQ.0) GO TO 6000 CALL CCPDPN(9,'KARLE.TM','SCRATCH','F',80,0) c OPEN(UNIT=9,FILE='KARLE.TM',FORM='FORMATTED',STATUS='UNKNOWN') 1415 READ (10,90) N DO 1421 JX=1,80 DO 1420 J=1,26 IF (LETT(J).EQ.N(JX)) GO TO 1425 1420 CONTINUE 1421 CONTINUE WRITE (9,90) N GO TO 1415 1425 KS=1 MEQ=0 c CLOSE (9) GO TO 100 1430 WRITE (6,1435) IMKK,IMKMAX 1435 FORMAT(//44H NUMBER OF STARTING PHASES INPUT TO PHASE =, 1 I5//17X,36HMAXIMUM NUMBER ALLOWED IS KUSER3/4 =,I5) GO TO 6000 C *PLT* PARTIAL LIST OF CONVERGENCE MAP 1440 LSTP = 0 GO TO 100 C *POS* POSITIONED MOLECULAR GROUP 1445 IND=4 GO TO 1710 C *PPM* PATTERSON MINIMUM FUNCTION 1447 MFP = 2 GO TO 1401 C *PPS* PATTERSON SUM FUNCTION 1449 MFP = 4 GO TO 1401 C *PRO* LOWEST PROBABILITY FOR ACCEPTANCE OF SIGMA-1 PHASE 1460 PROB = FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *PSI* WEIGHT OF THE PSIZERO FIGURE OF MERIT 1470 WTFOM(2) = FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *RAN* RANDOMLY POSITIONED MOLECULAR GROUP 1480 IND=2 GO TO 1710 C *RES* WEIGHT OF THE RISDUAL FIGURE OF MERIT 1490 WTFOM(3) = FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *RHO* MAXIMUM VALUE OF (SIN(THETA)/LAMBDA)**2 ACCEPTED 1550 RHOCUT=FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *RSC* RESCALE 1560 IF (ISC.NE.2) ISC=0 WRITE (6,1565) 1565 FORMAT(/1X,24X,30HRESCALING FOR EACH INDEX GROUP) GO TO 100 C *RST* RATIO BETWEEN THE NUMBER OF 'STRONG' REFLECTIONS C AND THAT OF THE TOTAL 1570 RSTT=FLOAT(IB(1))*10.0**IDIV(1) GO TO 100 C *SCA* SCALE FACTORS FOR INDIVIDUAL REFLECTION GROUPS 1575 DO 1577 J=1,8 IF (J.LT.IC) SCAL(J)=FLOAT(IB(J))*10.0**IDIV(J) 1577 CONTINUE IC1=IC-1 IF (IC1.GT.1.AND.ISC.EQ.1) ISC=0 JUMP=JUMP+1 GO TO 100 C *SET* SPECIFYING PHASE SETS TO BE DEVELOPED 1590 IPUB = MIN0(IB(1),KUSER3) IF (IPUB.EQ.0) GO TO 6000 CALL CCPDPN(9,'KARLE.TM','SCRATCH','F',80,0) c OPEN(UNIT=9,FILE='KARLE.TM',FORM='FORMATTED',STATUS='UNKNOWN') 1592 READ (10,90) N DO 1596 JX=1,80 DO 1594 J=1,26 IF (LETT(J).EQ.N(JX)) GO TO 1598 1594 CONTINUE 1596 CONTINUE WRITE (9,90) N GO TO 1592 1598 KS=1 MEQ=0 c CLOSE (9) GO TO 100 C *SKI* SKIP THE FIRST N SETS IN PHASE DEVELOPMENT 1600 ISKIP = IB(1) GO TO 100 C *SOL* SOLVING ENANTIOMORPH AMBIGUITY 1610 IND=8 ISOL=1 NRAN=500 X0(1)=0.0 X0(2)=0.0 X0(3)=0.0 IF (IC.LE.1) GO TO 1710 IF (IC.NE.4) GO TO 6000 X0(1)=FLOAT(IB(1))*10.0**IDIV(1) X0(2)=FLOAT(IB(2))*10.0**IDIV(2) X0(3)=FLOAT(IB(3))*10.0**IDIV(3) GO TO 1710 C *SPE* SPECIAL RESCALING 1620 ISC=2 MG=IB(1) GO TO 100 C *SPG* SET UP LINE FOR SPGR; READ TO SPACE, THEN TO NON-SPACE 1630 KS=MAX0(1,MOD(KS+1,81)) IF (N(KS).NE.KSP) GO TO 1630 1640 KS=MAX0(1,MOD(KS+1,81)) IF (N(KS).EQ.KSP) GO TO 1640 CALL SPGR(N,KS,IERR) IF (IERR.EQ.1) GO TO 6000 GO TO 80 C *SPT* NUMBER OF SPECIALS IN STARTING SET 1650 NSPEC = IB(1) GO TO 100 C *STO* NO RUNNING OF "PHASE" 1660 ISTO = 1 GO TO 100 C *SWT* STATISTICALLY WEIGHTED TANGENT REFINEMENT 1670 ITAN = 1 GO TO 100 C *UNW* UNIT WEIGHT FOR FOURIER OR DEFFERENCE FOURIER 1680 ISIM=0 GO TO 100 C *WFO* WEIGHTED FOURIER 1690 IND=6 ISTO = 1 GO TO 1710 C *WMI* INITIAL WEIGHT FOR THE RANDOM STARTING PHASES 1700 IWMIN = INT(100.0*FLOAT(IB(1))*10.0**IDIV(1)) GO TO 100 1710 NGP=NGP+1 NINF(NGP)=IND IND=4 NAG(NGP)=0 POP(NGP)=1.0 GO TO 100 1720 WRITE (6,1730) 1730 FORMAT (//1X,48H** MORE THAN 250 REFLEXIONS INPUT TO CONVERGE **) GO TO 6000 2100 NK=NK+1 NW(NK)=KEY KEY=1000 IKW=3 GO TO 110 2150 NA(NK)=IB(1) GO TO 100 2200 NAG(NGP)=NAG(NGP)+1 NTOT=NTOT+1 DO 2210 I=1,NK IF (KEY.EQ.NW(I)) GO TO 2230 2210 CONTINUE GO TO 6000 2230 NZ(NTOT)=I KEY=2000 IKW=3 GO TO 110 2250 IF (IC.GT.1) X(NTOT)=FLOAT(IB(1))*10.0**IDIV(1) IF (IC.GT.2) Y(NTOT)=FLOAT(IB(2))*10.0**IDIV(2) IF (IC.GT.3) Z(NTOT)=FLOAT(IB(3))*10.0**IDIV(3) IF (IC.GT.5) Q(NTOT)=FLOAT(IB(5))*10.0**IDIV(5) IF (IC.GT.6) U11(NTOT)=FLOAT(IB(6))*10.0**IDIV(6) IF (IC.GT.7) U22(NTOT)=FLOAT(IB(7))*10.0**IDIV(7) IF (IC.GT.8) U33(NTOT)=FLOAT(IB(8))*10.0**IDIV(8) IF (IC.GT.9) U23(NTOT)=FLOAT(IB(9))*10.0**IDIV(9) IF (IC.GT.10) U13(NTOT)=FLOAT(IB(10))*10.0**IDIV(10) IF (IC.GT.11) U12(NTOT)=FLOAT(IB(11))*10.0**IDIV(11) IF (IC.LE.6) GO TO 100 BTT=0.0 DO 2270 J=1,8 BT(J)=0.0 2270 CONTINUE GO TO 100 2300 DO 2310 JF=1,NK IF (KEY.EQ.NW(JF)) GO TO 2320 2310 CONTINUE GO TO 6000 2320 KEY=3000 IKW=3 GO TO 110 2350 IF (IC.GT.1) AL(JF)=FLOAT(IB(1))*10.0**IDIV(1) IF (IC.GT.2) AS(JF)=FLOAT(IB(2))*10.0**IDIV(2) IF (IC.GT.3) BL(JF)=FLOAT(IB(3))*10.0**IDIV(3) IF (IC.GT.4) BS(JF)=FLOAT(IB(4))*10.0**IDIV(4) IF (IC.GT.5) CL(JF)=FLOAT(IB(5))*10.0**IDIV(5) IF (IC.GT.6) CS(JF)=FLOAT(IB(6))*10.0**IDIV(6) IF (IC.GT.7) DL(JF)=FLOAT(IB(7))*10.0**IDIV(7) IF (IC.GT.8) DS(JF)=FLOAT(IB(8))*10.0**IDIV(8) IF (IC.GT.9) EL(JF)=FLOAT(IB(9))*10.0**IDIV(9) IF (IC.GT.10) GO TO 6000 GO TO 100 C END OF KEYWORD FILE 2800 IF (NON.EQ.1) GO TO 5000 C MARK FOR WILSON STATISTICS WITH KNOWN ATOMIC POSITIONS KNOWN=0 DO 2802 L=1,10 IF (NINF(L).EQ.4) KNOWN=1 2802 CONTINUE C CALCULATE ATOMIC SCATTERING FACTORS CALL ATMCOEF NAT=0 DO 2805 L=1,80 M(L)=KSP 2805 CONTINUE if (na(1).lt.0) then CALL LROPEN (1,'HKLIN',1,IFAIL) IF (IFAIL.EQ.1) CALL CCPERR(1,'Error opening HKLIN') CALL LRCELL(1,CELLP) do i = 1, 6 cx(i) = cellp(i) end do call incell NA(1)=VOLUME*0.036/240. CALL lrclos(1) end if DO 2810 L=1,NK K=NW(L)/100 J=NW(L)-100*K IF (K.GT.0) M(L)=LETT(K) IF (J.GT.0) M(L+40)=LETT(J) NW(L)=NA(L) C NO(L)=INT(AL(L)+BL(L)+CL(L)+DL(L)+EL(L)+0.5) IF (NO(L).GT.1) NAT=NAT+NA(L) MARKNO(NO(L))=L 2810 CONTINUE NRHV=0 NRLT=0 NOLT=0 DO 2820 L=2,98 IF (MARKNO(L).EQ.0) GOTO 2820 IF (FLOAT(NAT-NRLT)/NAT.GT.0.1.OR.FLOAT(L).LT.1.8*NOLT) 1 GOTO 2812 NRHV=NAT-NRLT GOTO 2822 2812 NRLT=NRLT+NA(MARKNO(L)) NOLT=L IF (NAT-NRLT.EQ.0) GOTO 2822 2820 CONTINUE 2822 IF (IHAR.EQ.0.AND.NRHV.GT.0) 1 IHAR=NRHV/PTS-NRHV/(PTS*NSYM*(ICENT+1))+2 IF (IHAR.EQ.0) IHAR=2*(NSYM*(ICENT+1)-1) IF (NHAR.EQ.0.AND.(IAPA.GT.1.AND.IAPA.LT.4)) THEN NHAR=NRHV*(NAT-NRHV)/(PTS*PTS*NSYM*(ICENT+1)) IF (NHAR.EQ.0) NHAR=100 ENDIF WRITE (6,2825) (M(L),M(L+40),NA(L),NO(L),L=1,NK) WRITE (6,2826) (M(L),M(L+40), 1 AL(L),AS(L),BL(L),BS(L),CL(L),CS(L),DL(L),DS(L),EL(L),L=1,NK) 2825 FORMAT(/1X,19HUNIT CELL CONTENTS:/ 1 1X,22X,4HATOM,3X,14HNUMBER IN CELL,2X,13HATOMIC NUMBER/ 2 (1H ,24X,2A1,7X,I5,11X,I3)) 2826 FORMAT(/1X,'SCATTERING FACTOR CONSTANTS:'//7X,'F=', 1 'AA*EXP(-A*RHO)+BB*EXP(-B*RHO)+CC*EXP(-C*RHO)+DD*EXP(-D*RHO)+E'/ 2 /8X,'AA A BB B CC C DD D', 3 ' E'/ (1H ,2A1,9F8.3)) DO 2830 L=1,142 GIS(L)=0.0 2830 CONTINUE IF (NGP.EQ.0) GO TO 2880 NF=0 DO 2870 L=1,NGP NS=NF+1 NF=NF+NAG(L) IF (NINF(L).EQ.2) WRITE (6,2842) 2842 FORMAT(/1X,'RANDOMLY ORIENTED CLUSTER(S) FOR WILSON STATISTICS:') IF (NINF(L).EQ.3) WRITE (6,2843) 2843 FORMAT(/1X,'CORRECTLY ORIENTED CLUSTER(S) FOR WILSON STATISTICS:') IF (NINF(L).EQ.4) WRITE (6,2844) 2844 FORMAT(/1X,'CORRECT POSITIONED CLUSTER(S) FOR WILSON STATISTICS:') IF (NINF(L).EQ.5) WRITE (6,2845) 2845 FORMAT(/1X,'ATOMS FOR KARLE RECYCLING:') IF (NINF(L).EQ.6.AND.ISIM.EQ.1) WRITE (6,2846) IF (NINF(L).EQ.6.AND.ISIM.EQ.0) WRITE (6,2847) 2846 FORMAT(/1X,'ATOMS FOR WEIGHTED FOURIER:') 2847 FORMAT(/1X,'ATOMS FOR UNWEIGHTED FOURIER:') IF (NINF(L).EQ.7.AND.ISIM.EQ.1) WRITE (6,2848) 2848 FORMAT(/1X,'ATOMS FOR WEIGHTED DIFFERENCE FOURIER:') IF (NINF(L).EQ.7.AND.ISIM.EQ.0) WRITE (6,2849) 2849 FORMAT(/1X,'ATOMS FOR UNWEIGHTED DIFFERENCE FOURIER:') IF (NINF(L).EQ.8) WRITE (6,2852) X0(1),X0(2),X0(3) 2852 FORMAT(/1X,'ATOMS FOR SOLVING ENANTIOMORPHOUS AMBIGUITY:'/ 1 3X,'PSEUDO-INVERSE CENTRE:', 1 ' X=',F5.2,' Y=',F5.2,' Z=',F5.2) IF (NGP.GT.1) WRITE (6,2853) L,NAG(L),POP(L) 2853 FORMAT(/3X,'CLUSTER',I4,3X, 1 'NUMBER OF ATOMS =',I3,3X,'MULTIPLICITY =',F5.1) WRITE (6,2854) 2854 FORMAT(/9X,'ATOM',11X,'X',14X,'Y',14X,'Z',9X,'OCCUPANCY') DO 2860 J=NS,NF K=NZ(J) IF (NINF(L).LE.2) NA(K)=NA(K)-INT(POP(L)+0.5) IF (NINF(L).EQ.4.OR.NINF(L).EQ.6.OR.NINF(L).EQ.7) GO TO 2856 WRITE (6,2855) M(K),M(K+40),X(J),Y(J),Z(J) 2855 FORMAT(1H ,9X,2A1,3F15.4) GO TO 2860 2856 NA(K)=NA(K)-INT(NSYM*(ICENT+1)*Q(J)*PTS+0.5) WRITE (6,2858) M(K),M(K+40),X(J),Y(J),Z(J),Q(J) 2858 FORMAT(1H ,9X,2A1,4F15.4) 2860 CONTINUE IF (NGP.EQ.1) WRITE (6,2867) NAG(1) 2867 FORMAT(/1X,'NUMBER OF INPUT ATOMS =',I4) C CALCULATE SPHERICALLY AVERAGED MOLECULAR SCATTERING FACTORS DO 2869 J=1,6 F(J)=CR(J,L) 2869 CONTINUE IF (NINF(L).EQ.2) CALL DEBYE(NS,NF,F,POP(L)) 2870 CONTINUE C CALCULATE WILSON (GIW) AND DEBYE (GIS) SCATTERING FACTORS 2880 DO 2900 L=1,142 T=0.01*FLOAT(L-1) TT=T*T GIW(L)=0.0 DO 2890 J=1,NK FZ=AL(J)*EXP(-AS(J)*TT)+BL(J)*EXP(-BS(J)*TT) 1 +CL(J)*EXP(-CS(J)*TT)+DL(J)*EXP(-DS(J)*TT)+EL(J) GIS(L)=GIS(L)+FZ*FZ*FLOAT(NA(J)) GIW(L)=GIW(L)+FZ*FZ*FLOAT(NW(J)) 2890 CONTINUE 2900 CONTINUE 5000 II=0 IF (NAPA.NE.0) IAPA=4 IF (IAPA.NE.0.AND.IPAT.EQ.0) IPAT=2 IF (MFP.NE.10.AND.IPAT.EQ.0) IPAT=2 IF (MFP.EQ.10.AND.IAPA.EQ.0.AND.IPAT.NE.0.AND.NOJOIN.EQ.0) 1 NOJOIN=1 c CLOSE (10,STATUS='DELETE') c close (10) CALL CCPDPN(34,'PHASKW.TM','SCRATCH','F',80,0) c OPEN(4,FILE='PHASKW.TM',FORM='FORMATTED',STATUS='UNKNOWN') C OUTPUT FOR PHASE WRITE (34,5810) PROB,CUT1,CUT2,WTFOM 5810 FORMAT(5X,3HPRO,7X,3HACU,7X,3HBCU,7X,3HABS,7X,3HPSI,7X,3HRES, 1 /6F10.4) WRITE (34,5820) KMIN,IPATH,ISTAGE,LSTP,NSREQ,NANY,NGEN,NSPEC, 1 IFAST,IFOM,ITAN,ISKIP,IMKK,IPUB,ISTO,IOFR,MKREJ, 2 NDET,KMAX,NRAN,IWMIN,NINPUT 5820 FORMAT(' KMI LAS NOM PLT MAX ANY GEN SPT FAS EFM SWT SKI ITL', 1' SET STO OFR NOR'/17I4/' DET KMA NRA WMI INP'/5I5) IF(NINPUT.GT.0) WRITE (34,5830) (ICONV(I),I=1,NINPUT) 5830 FORMAT(6I12) c CLOSE (4) CALL CCPDPN(20,'EXFFKW.TM','SCRATCH','F',80,0) c OPEN(20,FILE='EXFFKW.TM',FORM='FORMATTED',STATUS='UNKNOWN') C OUTPUT FOR EXFFT MAP AND AAPM IF (IPAT.GT.0.AND.MFP.EQ.10.AND.NPK.EQ.0) 1 NPK=INT(FLOAT(NHAR)*1.1+0.5) WRITE (20,5845) NOSET DO 5842 I=1,NK IF (I.NE.1) GO TO 5840 NAMAX=NO(I) NAMIN=NO(I) GO TO 5842 5840 IF (NO(I).LT.6) GO TO 5842 IF (NO(I).GT.NAMAX) NAMAX=NO(I) IF (NO(I).LT.NAMIN) NAMIN=NO(I) 5842 CONTINUE IF (ISOL.NE.1) GO TO 5844 DO 5843 J=1,3 5843 VECT(1,J)=X0(J) 5844 NALIM=NAMAX*NAMIN/4 WRITE (20,5850) ISOL,MFP,MN,IPAT,NALIM,GRID, 1 ((VECT(I,J),J=1,3),I=1,8) WRITE (20,5838) IAPA,IHAR,NHAR,NHV,NPK,DM,X00 5838 FORMAT(5H APA ,4HHAR ,4HNHAR,4H NHV,4H NPK,8H DM /I4, 1 1X,I3,1X,I3,2X,I2,I4,F8.4,10(/12F10.4)) c CLOSE (20) C OUTPUT FOR SEARCH CALL CCPDPN(11,'SEARCH.TM','SCRATCH','F',80,0) c OPEN(11,FILE='SEARCH.TM',FORM='FORMATTED',STATUS='UNKNOWN') WRITE (11,5860) NAA,MFRN,NPK,METAL,NOJOIN,IAPA ANAT=FLOAT(NAT)/(PTS*FLOAT((ICENT+1)*NSYM)) WRITE (11,5870) ANGMI,ANGMA,DMIN,DMAX,DMUT,DM,DFRG,NK,ANAT DO 5854 L=1,NK WRITE (11,5875) M(L),M(L+40),NW(L),NO(L) 5854 CONTINUE 5845 FORMAT(5HNOSET/I5) 5850 FORMAT(' ISO FMP NVE IPA CUT GRID', 1 /5I4,F8.5,8(/3F10.4)) 5860 FORMAT(38H ATOM MOL PEAK MET NOJ APA /6I6) 5870 FORMAT(53H AMIN AMAX DMIN DMAX DMUT DM DFRG/ 1 2F7.2,5F8.4,I4,F8.2) 5875 FORMAT(2A1,2I6) NTOTAL=4+NK+NAA+MFRN IF (NAA.EQ.0) GO TO 5700 DO 5600 I=1,NAA READ (7,90) N WRITE (11,90) N 5600 CONTINUE 5700 IF (MFRN.EQ.0) GO TO 5900 DO 5800 I=1,MFRN READ (7,90) N WRITE (11,90) N 5800 CONTINUE 5900 CONTINUE c CLOSE (11) CLOSE (7) RETURN 6000 WRITE (6,6010) N 6010 FORMAT(14H ERROR IN LINE,5X,80A1) C CLOSE (6) CLOSE (7) STOP' --- ERROR in PREPARE ---' END C----------------------------------------------------------------------- SUBROUTINE OUTPUT(N,M) C PRINT AND OUTPUT TO FILE FOR REFLEXIONS TO BE USED IN PHASE COMMON/REFLXOUT/IX(30000),EX(30000),FX(30000),SCMK(30000) COMMON/RESCALING/ISC,IBGR,MG,MIG(8),SCL,BT(9),SC(9),IP(8,3,5), 1 SCAL(8) COMMON/UNIT1/ITLE(80),LIST,PI DIMENSION J(3),K(3),L(3),E(3),KODE(3) CHARACTER ITLE IF (N.EQ.M) GO TO 60 WRITE (6,10) 10 FORMAT(1X,3(8H CODE,9H H K L,3X,1HE,2X)) NA=N+1 KK=0 DO 50 JJ=NA,M I=JJ IF (N.NE.0) I=M-JJ+NA KK=KK+1 IG=IABS(MOD(IX(I),32)) IX(I)=IX(I)/32 IND=IX(I) J(KK)=IND/65536 IF (IND.LT.0) J(KK)=J(KK)-1 IND=IND-65536*J(KK) K(KK)=IND/256 L(KK)=IND-256*K(KK)-128 K(KK)=K(KK)-128 SCK=FLOAT(ISIGN(1,MIG(IG)))*SQRT(SCAL(IG)) IF (N.NE.0) GO TO 25 SCMK(I)=SCK WRITE (1,20) J(KK),K(KK),L(KK),EX(I),SCMK(I) 20 FORMAT(3I5,2F10.3) GO TO 28 25 WRITE (1,20) J(KK),K(KK),L(KK),EX(I),SCK 28 E(KK)=EX(I) KODE(KK)=JJ-N IF (KK.NE.3) GO TO 50 WRITE (6,30) (KODE(II),J(II),K(II),L(II),E(II),II=1,3) 30 FORMAT(1X,3(3X,I5,3I3,F6.3)) KK=0 50 CONTINUE IF (KK.EQ.0) GO TO 60 WRITE (6,30) (KODE(II),J(II),K(II),L(II),E(II),II=1,KK) 60 KK=0 D=-1.0 WRITE (1,20) KK,KK,KK,D,D RETURN END C----------------------------------------------------------------------- SUBROUTINE PATT C CALCULATE A AND B FOR PATTERSON FUNCTION COMMON/ATMFACTOR/AL(8),AS(8),BL(8),BS(8),CL(8),CS(8),DL(8),DS(8), 1 EL(8),NW(8),NO(8),NK,NAT,F(9) COMMON/REFLXIN/LH(600),LK(600),LL(600),FO(600),ID(600),RHO(600), 1 SIG(600),XKP(600) COMMON/RESCALING/ISC,IBGR,MG,MIG(8),SCL,BT(9),SC(9),IP(8,3,5), 1 SCAL(8) COMMON/UNIT1/ ITLE(80),LIST,PI,KCURV,IPAT,IAPA,MOV,MFP,NAU COMMON/WILSON/FLGW(30,9),FLGD(30,9),AVR(30,9),DCV(50,9),SLOPE(9), 1 FLGK(9),DEL(9),KS(9),EW(600),ED(600),EDP(600) CHARACTER ITLE REWIND 8 100 READ (8) LH,LK,LL,FO,ID,EW,ED,RHO,SIG DO 200 I=1,600 IF (FO(I).LT.0) GO TO 300 D=EXP(BT(1)*RHO(I)) c D=1.0 IF (IPAT.NE.1) GO TO 80 IF (MOV.EQ.0) EW(I)=FO(I)*FO(I)*D*SC(1) IF (MOV.NE.0) EW(I)=FO(I)*FO(I)*D*SC(1)*(1.0-1/EW(I)) GO TO 150 80 IF (IPAT.EQ.3) GO TO 90 IF (MOV.EQ.0) EW(I)=FO(I)*SQRT(ED(I))*D*SC(1) IF (MOV.NE.0) EW(I)=FO(I)*SQRT(ABS(ED(I)-1))*D*SC(1) GO TO 150 90 IF (MOV.EQ.0) EW(I)=ED(I) IF (MOV.NE.0) EW(I)=ABS(ED(I)-1) 150 ED(I)=0.0 200 CONTINUE WRITE (2) LH,LK,LL,EW,ED,RHO,RHO,RHO,RHO GO TO 100 300 LH(I)=-1000 WRITE (2) LH,LK,LL,EW,ED,RHO,RHO,RHO,RHO RETURN END C----------------------------------------------------------------------- SUBROUTINE RECYC(NS,NF,KMARK) C PHASE CALCULATION FOR WEIGHTED KARLE RECYCLING COMMON/ATMFACTOR/AL(8),AS(8),BL(8),BS(8),CL(8),CS(8),DL(8),DS(8), 1 EL(8),NW(8),NO(8),NK,NAT,F(9) COMMON/ATMGROUP/NINF(10),NAG(10),X(5000),Y(5000),Z(5000),NZ(5000), 1 Q(5000),U11(5000),U22(5000),U33(5000),U23(5000), 2 U13(5000),U12(5000) COMMON/REFLXIN/LH(600),LK(600),LL(600),FO(600),ID(600),RHO(600), 1 SIG(600),XKP(600) COMMON/REFLXOUT/IX(30000),EX(30000),FX(30000),SCMK(30000) COMMON/RESCALING/ISC,IBGR,MG,MIG(8),SCL,BT(9),SC(9),IP(8,3,5), 1 SCAL(8) COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT COMMON/UNIT1/ ITLE(80),LIST,PI,KCURV,IPAT,MOE,MFP,NAU COMMON/WILSON/FLGW(30,9),FLGD(30,9),AVR(30,9),DCV(50,9),SLOPE(9), 1 FLGK(9),DEL(9),KS(9),EW(600),ED(600),EDP(600) COMMON/XXX/P(6),CX(9),NREF,NB,RHOMAX,MM,EMAX,EN,MZ,ER,ISIM,RHOCUT 1 ,RHOMIN,RHOLOW DIMENSION I1(3),I2(3),IFAZ(15000),VECT(8,3) DIMENSION WTFOM(3) CHARACTER ITLE C I1/I0 (BESSEL FUNCTIONS) VEC(U)=U*(U+0.4807)/((U+0.8636)*U+1.3943) CALL CCPDPN(4,'KARLE.TM','SCRATCH','F',80,0) c OPEN(4,FILE='KARLE.TM',FORM='FORMATTED',STATUS='UNKNOWN') C CALCULATE PKARL (RATIO OF KNOWN TO COMPLETE STRUCTURE) KARL=0 MARK=-1 DO 150 I=NS,NF K=NZ(I) KARL=KARL+NO(K)*NO(K) 150 CONTINUE KTOT=0 DO 160 I=1,NK KTOT=KTOT+NW(I)*NO(I)*NO(I) 160 CONTINUE PKARL=FLOAT(KARL*NSYM*(ICENT+1))*PTS/FLOAT(KTOT) IF (PKARL.LT.0.25) MARK=1 WRITE (6,180) ITLE,PKARL 180 FORMAT (//1X,76(1H+)//80A1//20X,'PHASE CALCULATION FOR KARLE ', 1'RECYCLING'//19X,39HRATIO OF KNOWN TO COMPLETE STRUCTURE IS,F6.2) IF (PKARL.LT.0.25) PKARL=0.25 IF (PKARL.GT.0.60) PKARL=0.60 C CALCULATE PHASES AND SELECT REFLEXIONS FOR INPUT TO PHASE REWIND 8 SUMF=0.0 SUMC=0.0 200 READ (8) LH,LK,LL,FO,ID,EW,ED,RHO,SIG DO 300 I=1,600 IF (FO(I).LT.0.0) GO TO 310 IIP=65536*LH(I)+256*(LK(I)+128)+LL(I)+128 IG=MOD(ID(I),100) DO 210 IM=1,MM IF (IX(IM).EQ.IIP) GO TO 220 210 CONTINUE GO TO 300 220 SUMF=SUMF+FX(IM) I1(1)=LH(I) I1(2)=LK(I) I1(3)=LL(I) REL=0.0 RIM=0.0 IENT=0 DO 260 J=1,NSYM T=1000.0 DO 250 L=1,3 T=T+FLOAT(I1(L))*TS(L,J) I2(L)=IS(L,1,J)*I1(1) + IS(L,2,J)*I1(2) + IS(L,3,J)*I1(3) 250 CONTINUE CALL SFAC(NS,NF,I2,T,RHO(I),A,B,IENT) IENT=1 REL=REL+A IF (ICENT.EQ.0) RIM=RIM+B IF (ICENT.EQ.1) REL=REL+A 260 CONTINUE E=EX(IM) EX(IM)=PTS*SQRT((REL*REL+RIM*RIM)*EXP(-BT(IG)*RHO(I))) SUMC=SUMC+EX(IM) IFAZ(IM)=0 C CALCULATE SIM WEIGHT XKAP=2.0*E*E*EX(IM)/((1.0-PKARL)*FX(IM)) IF (XKAP.GT.4.0) GO TO 280 IF (XKAP.LT.2.4.OR.E.LT.1.5.OR.EX(IM).LT.PKARL*FX(IM)) GO TO 300 280 IF (ICENT.EQ.0) EX(IM+15000) = VEC(XKAP) IF (ICENT.EQ.1) EX(IM+15000) = TANH(XKAP/2.0) FAZE=(180.0/PI)*ATAN2(RIM,REL)+360.0 IFAZ(IM)=MOD(INT(FAZE+0.5),360) IF (IFAZ(IM).EQ.0) IFAZ(IM)=360 300 CONTINUE GO TO 200 310 SCALE=SUMC/SUMF RS=0.0 NREC=0 DO 350 I=1,MM RS=RS+ABS(SCALE*FX(I)-EX(I)) IF (IFAZ(I).LE.0) GO TO 350 NREC=NREC+1 IX(NREC)=I IX(NREC+15000)=IFAZ(I) FX(NREC+15000)=EX(I+15000) 350 CONTINUE RS=100.0*RS/SUMC IF (NREC.GT.7500) NREC=7500 WRITE (6,360) SCALE,RS,NREC 360 FORMAT (/19X,7HSCALE =,F7.3,14X,10HR-FACTOR =,F7.2//20X, 1 38HNUMBER OF REFLEXIONS PASSED TO PHASE =,I5//1X,76(1H+)) WRITE (4,370) ITLE,NREC 370 FORMAT(80A1/7HPHASES ,I4) WRITE (4,380) (IX(I),I=1,NREC) 380 FORMAT(15I5) WRITE (4,380) (MARK,I=1,NREC) WRITE (4,390) (FX(I+15000),I=1,NREC) 390 FORMAT(15F5.2) IF (KMARK.EQ.0) MARK=555 IF (KMARK.NE.0) MARK=-1 WRITE (4,380) (IX(I+15000),I=1,NREC),MARK c CLOSE (4) RETURN END C----------------------------------------------------------------------- SUBROUTINE RESCA(KSYS,JUMP) C INDEX GROUP RESCALING COMMON/REFLXIN/LH(600),LK(600),LL(600),FO(600),ID(600),RHO(600), 1 SIG(600),XKP(600) COMMON/RESCALING/ISC,IBGR,NN,MIG(8),SCL,BT(9),SC(9),IP(8,3,5), 1 SCAL(8) COMMON/UNIT1/ITLE(80),LIST,PI,KCURV COMMON/WILSON/FLGW(30,9),FLGD(30,9),AVR(30,9),DCV(50,9),SLOPE(9), 1 FLGK(9),DEL(9),KS(9),EW(600),ED(600),EDP(600) COMMON/XXX/P(6),CX(9),NREF,NB,RHOMAX,MM,EMAX,EN,MZ,ER,ISIM,RHOCUT, 1 RHOMIN,RHOLOW,ENG(8),ERG(8),KNOWN,IPATH,VOLUME DIMENSION NG(8),SCS(8) CHARACTER ITLE IF (IBGR.EQ.1.AND.ISC.EQ.1) ISC=0 IF (JUMP.GE.0) KCURV=0 TOT=0.0 IIG=1 IF (IBGR.EQ.1) IIG=NN+1 NW=0 DO 10 I=1,8 SCS(I)=0.0 NG(I)=0 10 CONTINUE IF (KCURV.EQ.0) WRITE (6,80) IF (KCURV.EQ.1) WRITE (6,90) 80 FORMAT(/1X,12X,'***** NORMALIZATION BY LEAST SQUARES STRAIGHT' 1 ,'LINE *****'/) 90 FORMAT(/1X,12X,'***** NORMALIZATION BY K CURVE OR DEBYE CURVE' 1 ,' *****'/) REWIND 8 100 READ (8) LH,LK,LL,FO,ID,EW,ED,RHO,SIG,EDP DO 250 I=1,600 IF (FO(I).LT.0.0) GO TO 300 IG=MOD(ID(I),100) IF (KCURV.EQ.0) ESQ=ED(I)*EXP(BT(IG)*RHO(I)) IF (KCURV.EQ.1) CALL CURVK(ESQ,RHO(I),ED(I),IIG) C UNPACK SYMMETRY FUNCTIONS MULT=ID(I)/10000 TMUL=FLOAT(MULT) TOT=TOT+ESQ*TMUL NW=NW+MULT SCS(IG)=SCS(IG)+ESQ*TMUL NG(IG)=NG(IG)+MULT 250 CONTINUE GO TO 100 300 TOT=TOT/FLOAT(NW) C NN=8 (PARITY GROUPS) FOR TRICLINIC, MONOCLINIC AND ORTHORHOMBIC C NN=6 (MODIFIED PARITY GROUPS) FOR TETRAGONAL C NN=6 (INDEX GROUPS) IN OTHER SYSTEMS C NN=ANY NUMBER FROM 1 TO 8 FOR SPECIAL RESCALING DO 310 I=1,NN IF (NG(I).GT.0) SCS(I)=SCS(I)/(FLOAT(NG(I))*TOT) 310 CONTINUE C FIND OUT AND GIVE NEGATIVE MARK TO C INDEX GROUP HAVING INTENSITIES SYSTEMATICALLY WEAK 315 DO 320 I=1,NN IF (SCS(I).GT.0.00001.AND.SCS(I).LT.0.7) MIG(I)=2 IF (SCS(I).GT.0.00001.AND.SCS(I).LT.SCL) MIG(I)=-1 320 CONTINUE 325 WRITE (6,330) 330 FORMAT(/1X,6X,'AVERAGE E**2 ACCORDING TO APPROPRIATE INDEX ', 1 'GROUP BEFORE RESCALING') IF (ISC.EQ.2) GO TO 382 IF (KSYS.LE.3) WRITE (6,335) 335 FORMAT(/1X,33X,13HPARITY GROUPS/1X,13X,3HALL,4X,3HEEE,4X,3HOEE, 1 4X,3HEOE,4X,3HOOE,4X,3HEEO,4X,3HOEO,4X,3HEOO,4X,3HOOO) IF (KSYS.EQ.4) WRITE (6,340) 340 FORMAT(/1X,28X,22HMODIFIED PARITY GROUPS/1X,13X,3HALL,4X,3HEEE, 1 8X,7HEOE,OEE,8X,3HOOE,4X,3HEEO,8X,7HEOO,OEO,7X,3HOOO) IF (KSYS.LE.4) GO TO 365 WRITE (6,345) 345 FORMAT(/1X,25HINDEX GROUPS DIVIDED ON -) IF (KSYS.LE.6) WRITE (6,350) 350 FORMAT(10X,11H1) MOD(H,3),4X,11H2) MOD(K,3),4X, 1 13H3) MOD(H+K,3),4X,11H4) MOD(L,2)) IF (KSYS.GE.7) WRITE (6,355) 355 FORMAT(10X,13H1) MOD(H-L,3),4X,13H2) MOD(K-L,3),4X, 1 13H3) MOD(H-K,3),4X,15H4) MOD(H+K+L,2)) WRITE (6,360) 360 FORMAT(/1X,15X,18HE - ZERO REMAINDER,4X,22HO - NON-ZERO REMAINDER/ 1 /1X,14X,3HALL,3X,4HOOOE,1X,9HOOEE,OEOE,1X,4HEEEE,1X,4HOOOO, 2 1X,9HOOEO,OEOO,1X,4HEEEO/1H ,27X,4HEOOE,17X,4HEOOO) 365 TT=1.0000 IF(KSYS.EQ.4) THEN WRITE(6,366) TT,(SCS(I),I=1,NN) WRITE(6,368) NW,(NG(I),I=1,NN) ELSE WRITE(6,370) TT,(SCS(I),I=1,NN) WRITE(6,380) NW,(NG(I),I=1,NN) ENDIF 366 FORMAT(1H ,4X,4HE**2,2X,F7.3,F8.3,2F10.3,F8.3,2F10.3) 368 FORMAT(1H ,3X,6HNUMBER,1X,I7,I8,2I10,I8,2I10) 370 FORMAT(1H ,4X,4HE**2,2X,9F7.3) 380 FORMAT(1H ,3X,6HNUMBER,1X,9I7) GO TO 390 382 WRITE (6,383) 383 FORMAT(/1X,29X,20H INDEX GROUP E**2/) WRITE (6,385) (I,SCS(I),I=1,NN) 385 FORMAT(30X,I8,F12.3) 390 IF (JUMP.EQ.1) GO TO 500 TOT=1.0/TOT C TO DETERMINE IF INDEX GROUP RESCALING IS NEEDED. IF (ISC.NE.1) GO TO 398 DO 395 I=1,NN IF (MIG(I).EQ.-1.OR.MIG(I).EQ.2) ISC=0 IF (MIG(I).EQ.-1.OR.MIG(I).EQ.2) GO TO 398 395 CONTINUE WRITE (6,397) 397 FORMAT(/9X,37H*** NO RESCALING FOR INDIVIDUAL INDEX, 1 23H GROUPS IS REQUIRED ***,/) 398 DO 400 I=1,NN IF (NG(I).EQ.0) GO TO 399 SCAL(I)=TOT/SCS(I) 399 IF (ISC.EQ.1) SCAL(I)=TOT 400 CONTINUE 500 IF (ISC.EQ.1) GO TO 541 WRITE (6,540) SCL 540 FORMAT(/1X,10X,44H*** RESCALING FOR INDIVIDUAL INDEX GROUPS IS, 1 13H REQUIRED ***,/9X,34HREFLECTIONS IN INDEX GROUPS HAVING, 2 23H AVERAGE E**2 LESS THAN,F6.3/9X,23HARE TO BE RECOGNIZED AS, 3 34H 'SYSTEMATICALLY WEAK REFLECTIONS') 541 IF (JUMP.EQ.-1) WRITE (6,542) 542 FORMAT(/1X,11X,46HTEMPERATURE AND SCALING FACTORS DERIVED BY THE, 1 8H PROGRAM) IF (JUMP.EQ.0) WRITE (6,543) 543 FORMAT(/1X,20X,37HSCALING FACTOR DERIVED BY THE PROGRAM/ 1 1H ,12X,53H WITH THE TEMPERATURE FACTOR(BT) SUPPLIED BY THE USER) IF (JUMP.EQ.1) WRITE (6,544) 544 FORMAT(/1X,6X,41HTEMPERATURE FACTOR(BT) AND SCALING FACTOR, 1 21H SUPPLIED BY THE USER) WRITE (6,545) 545 FORMAT(1H ,16X,46H--- EXP{(-2*BT)*RHO}*FCAL**2=SCALE*FOBS**2 ---/ 1 1H ,24X,5HGROUP,5X,4H2*BT,6X,5HSCALE) IF (ISC.NE.1) WRITE (6,546) (I,BT(I),SCAL(I),I=1,NN) 546 FORMAT(1H ,27X,I1,2F11.4) IF (ISC.EQ.1) WRITE (6,548) BT(1),SCAL(1) 548 FORMAT(1H ,25X,3HALL,F10.4,F11.4) RETURN END C----------------------------------------------------------------------- SUBROUTINE RFAC(ICENT,NINF) C R-FACTOR CALCULATION COMMON/REFLXIN/LH(600),LK(600),LL(600),FO(600),ID(600),RHO(600), 1 FC(600),XKP(600) COMMON/RESCALING/ISC,IBGR,MG COMMON/XXX/P(6),CX(9),NREF,NB,RHOMAX,MM,EMAX,EN,MZ,ER,ISIM,RHOCUT, 1 RHOMIN,RHOLOW,SUMFCG(8),SUMFOG(8),KNOWN,IPATH,VOLUME,SUMFC,SUMFO DIMENSION RG(8),AO(600),BO(600),SCALEG(8),NINF(10) CALL CCPDPN(26,'FCOUT','UNKNOWN','F',80,0) c OPEN(26,FILE='FC.OUT',FORM='FORMATTED',STATUS='UNKNOWN') WRITE(26,20) 20 FORMAT(' H K L Fc PHAc') RTOD=45.0/ATAN(1.0) REWIND 2 READ (2) READ (2) R=0.0 SCALE=SUMFC/SUMFO DO 50 I=1,8 RG(I)=0.0 SCALEG(I)=0.0 IF(SUMFOG(I).GT.0.01) SCALEG(I)=SUMFCG(I)/SUMFOG(I) 50 CONTINUE REWIND 8 100 READ (8) LH,LK,LL,AO,BO,FO,FC,ID,RHO,XKP DO 200 I=1,600 IF (FO(I).LT.0.0) GO TO 250 IG=MOD(ID(I),100) RG(IG)=RG(IG)+ABS(FC(I)-FO(I)*SCALEG(IG)) FO(I)=SCALE*FO(I) R=R+ABS(FC(I)-FO(I)) C SIM WEIGHTING SCHEME FOR FOURIER WATE=1.0 IF (ISIM.EQ.0) GO TO 110 IF (ICENT.EQ.0) WATE=BS10(FO(I)*XKP(I)) IF (ICENT.EQ.1) WATE=TANH(FO(I)*XKP(I)/2.0) 110 COEFF=0.0 IF (FC(I).LT.0.00001) GO TO 120 IF (NINF(1).EQ.6) COEFF=FO(I)*WATE/FC(I) IF (NINF(1).EQ.7) COEFF=(FO(I)*WATE-FC(I))/FC(I) 120 AO(I)=AO(I)*COEFF BO(I)=BO(I)*COEFF PHAC=RTOD*ATAN2(BO(I),AO(I))+360.0 PHAC=AMOD(PHAC,360.0) IF(ABS(PHAC-360.0).LE.0.1) PHAC=0.0 FCS=FC(I)/SCALE WRITE(26,150) LH(I),LK(I),LL(I),FCS,PHAC 150 FORMAT(I5,2I4,F12.2,F10.2) 200 CONTINUE WRITE (2) LH,LK,LL,AO,BO,FO,FC,ID,RHO GO TO 100 250 R=100.0*R/SUMFC WRITE (2) LH,LK,LL,AO,BO,FO,FC,ID,RHO WRITE (6,280) R,NREF 280 FORMAT(/1X,14X,19HOVER ALL R-FACTOR =,F7.2,7H % FOR,I6,2X, 1 10HREFLEXIONS) DO 290 I=1,MG IF (SUMFCG(I).LT.0.001) GO TO 286 RG(I)=100.0*RG(I)/SUMFCG(I) GO TO 290 286 RG(I)=0.0 290 CONTINUE WRITE (6,300) 300 FORMAT(/1X,20X,37HR-FACTORS FOR INDIVIDUAL INDEX GROUPS/ 1 1H ,30X,16HGROUP R-FACTOR/) WRITE (6,310) (I,RG(I),I=1,MG) 310 FORMAT(1H ,27X,I5,4X,F7.2,' %') CLOSE (26) RETURN END C----------------------------------------------------------------------- SUBROUTINE SFAC(NS,NF,L,T,RHO,A,B,IENT) C STRUCTURE FACTOR CALCULATION COMMON/ATMFACTOR/AL(8),AS(8),BL(8),BS(8),CL(8),CS(8),DL(8),DS(8), 1 EL(8),NW(8),NO(8),NK,NAT,F(9) COMMON/ATMGROUP/NINF(10),NAG(10),X(5000),Y(5000),Z(5000),NZ(5000), 1 Q(5000),U11(5000),U22(5000),U33(5000),U23(5000), 2 U13(5000),U12(5000) COMMON/SINETABLE/SINT(450) COMMON/XXX/P(6),CX(9),NREF,NB,RHOMAX,MM,EMAX,EN,MZ,ER,ISIM,RHOCUT 1 ,RHOMIN,RHOLOW DIMENSION L(3),COST(360) EQUIVALENCE (SINT(91),COST(1)) A=0.0 B=0.0 IF (IENT.EQ.1) GO TO 30 DO 10 I=1,NK F(I)=AL(I)*EXP(-AS(I)*RHO)+BL(I)*EXP(-BS(I)*RHO)+CL(I)*EXP(-CS(I) 1 *RHO)+DL(I)*EXP(-DS(I)*RHO)+EL(I) 10 CONTINUE 30 HJ=FLOAT(L(1)) HK=FLOAT(L(2)) HL=FLOAT(L(3)) DO 50 I=NS,NF N=NZ(I) ARG=AMOD(HJ*X(I)+HK*Y(I)+HL*Z(I)+T,1.0) IARG=INT(360.0*ARG+0.5)+1 IF (IARG.EQ.361) IARG=1 IF (U11(I).GT.0.00001) GO TO 40 FJ=F(N) GO TO 45 40 UU = U11(I)*HJ*HJ*P(1)+U22(I)*HK*HK*P(2)+U33(I)*HL*HL*P(3) * +U12(I)*HJ*HK*P(4)+U13(I)*HJ*HL*P(5)+U23(I)*HK*HL*P(6) CT98 IF (U22(I).LT.0.00001) UU = U11(I)*RHO CT98 FJ=F(N)*EXP(-8*3.1416*3.1416*UU) IF (U22(I).GE.0.00001) UU = 8.0*3.1416*3.1416*UU IF (U22(I).LT.0.00001) UU = U11(I)*RHO FJ=F(N)*EXP(-UU) 45 A=A+FJ*Q(I)*COST(IARG) B=B+FJ*Q(I)*SINT(IARG) 50 CONTINUE RETURN END C----------------------------------------------------------------------- SUBROUTINE SOLENA(NS,NF,MMS) C PHASE CALCULATION FOR SOLVING ENANTIOMORPHOUS AMBIGUITY COMMON/ATMFACTOR/AL(8),AS(8),BL(8),BS(8),CL(8),CS(8),DL(8),DS(8), 1 EL(8),NW(8),NO(8),NK,NAT,F(9) COMMON/ATMGROUP/NINF(10),NAG(10),X(5000),Y(5000),Z(5000),NZ(5000), 1 Q(5000),U11(5000),U22(5000),U33(5000),U23(5000), 2 U13(5000),U12(5000) COMMON/REFLXIN/LH(600),LK(600),LL(600),FO(600),ID(600),RHO(600), 1 SIG(600),XKP(600) COMMON/REFLXOUT/IX(30000),EX(30000),FX(30000) COMMON/RESCALING/ISC,IBGR,MG,MIG(8),SCL,BT(9),SC(9),IP(8,3,5), 1 SCAL(8) COMMON/SCATFACTOR/GIS(142),GIW(142),NGP,NDIFF,ISOL,X0(3) COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT COMMON/UNIT1/ ITLE(80),LIST,PI,KCURV,IPAT,MOE,MFP,NAU COMMON/WILSON/FLGW(30,9),FLGD(30,9),AVR(30,9),DCV(50,9),SLOPE(9), 1 FLGK(9),DEL(9),KS(9),EW(600),ED(600),EDP(600) COMMON/XXX/P(6),CX(9),NREF,NB,RHOMAX,MM,EMAX,EN,MZ,ER,ISIM,RHOCUT 1 ,RHOMIN,RHOLOW DIMENSION I1(3),I2(3),FC(15000),IMARK(15000),WT(15000), 1 IFAZ(15000),IDEL(15000) CHARACTER ITLE C I1/I0 (BESSEL FUNCTIONS) VEC(U)=U*(U+0.4807)/((U+0.8636)*U+1.3943) CALL CCPDPN(4,'KARLE.TM','SCRATCH','F',80,0) c OPEN(4,FILE='KARLE.TM',FORM='FORMATTED',STATUS='UNKNOWN') SCALEF=SQRT(SC(1)) C CALCULATE PKSOL (RATIO OF KNOWN TO COMPLETE STRUCTURE) KSOL=0 KSW=0 IIG=1 IF (IBGR.EQ.1) IIG=MG+1 IF (NF-NS.GT.5) KSW=1 DO 150 I=NS,NF K=NZ(I) KSOL=KSOL+NO(K)*NO(K) 150 CONTINUE KTOT=0 DO 160 I=1,NK KTOT=KTOT+NW(I)*NO(I)*NO(I) 160 CONTINUE PKSOL=FLOAT(KSOL*NSYM*(ICENT+1))*PTS/FLOAT(KTOT) WRITE (6,180) ITLE,PKSOL 180 FORMAT (//1X,76(1H+)//80A1//24X,'SOLVING ENANTIOMORPHOUS AMBIG', 1'UITY'//18X,39HRATIO OF KNOWN TO COMPLETE STRUCTURE IS,F6.2) C CALCULATE PHASES AND DELTA PHASES BY SIM FORMULA REWIND 8 SUMF=0.0 SUMC=0.0 200 READ (8) LH,LK,LL,FO,ID,EW,ED,RHO,SIG DO 300 I=1,600 IF (FO(I).LT.0.0) GO TO 310 IIP=65536*LH(I)+256*(LK(I)+128)+LL(I)+128 DO 210 IM=1,MM IF (IX(IM)/32.EQ.IIP) GO TO 220 210 CONTINUE GO TO 300 220 SUMF=SUMF+FX(IM) I1(1)=LH(I) I1(2)=LK(I) I1(3)=LL(I) REL=0.0 RIM=0.0 IENT=0 DO 260 J=1,NSYM T=1000.0 DO 250 L=1,3 T=T+FLOAT(I1(L))*(TS(L,J)-X0(L)) I2(L)=IS(L,1,J)*I1(1) + IS(L,2,J)*I1(2) + IS(L,3,J)*I1(3) 250 CONTINUE CALL SFAC(NS,NF,I2,T,RHO(I),A,B,IENT) IENT=1 REL=REL+A RIM=RIM+B 260 CONTINUE E=EX(IM) FC(IM)=PTS*SQRT((REL*REL+RIM*RIM)*EXP(-BT(IIG)*RHO(I))) 265 SUMC=SUMC+FC(IM) IF (KSW.EQ.0) GO TO 280 C CALCULATE DELTA PHASE WITH B=SQRT(F*F-A*A) IFAZ(IM)=INT(360.0*AMOD(I1(1)*X0(1)+I1(2)*X0(2)+I1(3)*X0(3)+ 1 100.0,1.0)) FOBS=PKSOL*SCALEF*FO(I)*EXP(0.5*BT(IIG)*RHO(I))/PTS RIM1=FOBS*FOBS-REL*REL IF (RIM1.LT.0.0) RIM1=0.0 RIM1=SQRT(RIM1) DELTA=(180.0/PI)*ATAN2(RIM1,ABS(REL)) WT(IM)=DELTA IF (REL.LT.0.0) IFAZ(IM)=MOD(IFAZ(IM)+180,360) IF (IFAZ(IM).EQ.0) IFAZ(IM)=360 GO TO 300 C CALCULATE SIM WEIGHT 280 XKAP=2.0*E*E*FC(IM)/((1.0-PKSOL)*FX(IM)) FAZE=0.0 IF (FC(IM).LT.0.000001) GO TO 285 FAZE=(180.0/PI)*ATAN2(RIM,REL)+360.0 285 WT(IM)=(180.0/PI)*ABS(ACOS(VEC(XKAP))) IFAZ(IM)=MOD(INT(FAZE+0.5),360) IF (IFAZ(IM).EQ.0) IFAZ(IM)=360 300 CONTINUE GO TO 200 310 SCALE=SUMC/SUMF C CHOOSE MMS REFLECTIONS WITH LARGEST DELTA PHI FROM MM REFLECTIONS IF (MMS.EQ.MM) GO TO 950 NWEAK=0 NBB=0 C FIND THE NUMBERS FOR STRONG AND WEAK REFLECTION DO 500 I=1,MM IMARK(I)=1 IG=IABS(MOD(IX(I),32)) IF (MIG(IG).NE.-1) GO TO 400 NWEAK=NWEAK+1 WT(I)=0.0 IMARK(I)=2 IFAZ(I)=0 GO TO 500 400 IF (WT(I).LT.15.0) GO TO 500 NBB=NBB+1 IMARK(I)=3 500 CONTINUE NSTRON=MM-NWEAK NAA=NSTRON-NBB IF (NSTRON.LT.MMS/2.OR.NWEAK.LT.MMS/2) GO TO 550 NSTRON=MMS/2 NWEAK=MMS-NSTRON GO TO 600 550 IF (NWEAK.LT.MMS/2) NSTRON=MMS-NWEAK IF (NSTRON.LT.MMS/2) NWEAK=MMS-NSTRON 600 IF (NBB.LT.NSTRON*2/3.OR.NAA.LT.NSTRON/3) GO TO 650 NAA=NSTRON/3 NBB=NSTRON-NAA GO TO 700 650 IF (NBB.LT.NSTRON*2/3) NAA=NSTRON-NBB IF (NAA.LT.NSTRON/3) NBB=NSTRON-NAA C DELETE UNSUITABLE REFLECTIONS 700 CALL SORT(WT,EX,IMARK,MM) J=NBB+1 DO 750 I=J,MM IF (WT(I).LT.15.0) WT(I)=0.0 IF (WT(I).GE.15.0) IMARK(I)=0 750 CONTINUE CALL SORT(EX,WT,IMARK,MM) NCAA=0 NCWEAK=0 DO 800 I=1,MM KKSW=IMARK(I)+1 GO TO (800,760,770,800),KKSW 760 IF (NCAA.GT.NAA) GO TO 790 NCAA=NCAA+1 GO TO 800 770 IF (NCWEAK.GT.NWEAK) GO TO 790 NCWEAK=NCWEAK+1 GO TO 800 790 IMARK(I)=0 800 CONTINUE DO 900 I=1,MMS 830 IF (IMARK(I).NE.0) GO TO 880 DO 850 J=I,MM IMARK(J)=IMARK(J+1) IX(J)=IX(J+1) EX(J)=EX(J+1) IFAZ(J)=IFAZ(J+1) WT(J)=WT(J+1) FC(J)=FC(J+1) FX(J)=FX(J+1) 850 CONTINUE GO TO 830 880 IDEL(I)=INT(WT(I)) WT(I)=1.0 900 CONTINUE MM=MMS GO TO 1100 950 DO 1000 I=1,MM IDEL(I)=INT(WT(I)) WT(I)=1.0 1000 CONTINUE 1100 RS=0.0 WRITE (4,1320) 1320 FORMAT(1X,4HCODE,4X,1HH,4X,1HK,4X,1HL,5X,2HFO,5X,2HFC,6X,1HE, & 5X,2HWT,1X,4HPHIK,1X,4HDPHA/) DO 1350 I=1,MM RS=RS+ABS(SCALE*FX(I)-FC(I)) IND=IX(I)/32 IHH=IND/65536 IF (IND.LT.0) IHH=IHH-1 IND=IND-65536*IHH IKK=IND/256 ILL=IND-256*IKK-128 IKK=IKK-128 FOO=FX(I) FCC=FC(I) EO=EX(I) IPHIQ=IFAZ(I) IPHID=IDEL(I) WEIT=WT(I) WRITE (4,1325) I,IHH,IKK,ILL,FOO,FCC,EO,WEIT,IPHIQ,IPHID 1325 FORMAT(4I5,2F7.2,2F7.4,2I5) 1350 CONTINUE RS=100.0*RS/SUMC WRITE (6,1360) SCALE,RS,MM 1360 FORMAT (/18X,7HSCALE =,F7.3,14X,10HR-FACTOR =,F7.2//19X, 1 38HNUMBER OF REFLEXIONS PASSED TO PHASE =,I5) IF (KSW.EQ.0) WRITE (6,1400) IF (KSW.EQ.1) WRITE (6,1410) 1400 FORMAT(/1X,14X,'THE PHASE DIFFERENCES (PHD) ARE GENERATED ', 1'ACCORDING'/30X,'TO ',5HSIM'S,' DISTRIBUTION'//1X,76(1H+)) 1410 FORMAT(/1X,14X,'THE PHASE DIFFERENCES (PHD) ARE OBTAINED ', 1'ACCORDING'/15X,'TO A STRUCTURE MODEL WITH ENANTIOMORPHOUS ', 2'AMBIGUITY'//1X,76(1H+)) c CLOSE (4) RETURN END ************************************************************************ * * * SSSSS PPPPPP GGGGG RRRRRR * * S S P P G G R R * * S P P G R R * * SSSSS PPPPPP G GGGG RRRRRR * * S P G G R R * * S S P G G R R * * SSSSS P GGGGGG R R * * * * DERIVATION OF SYMMETRY OPERATIONS FROM THE SPACE GROUP SYMBOL * * A MODIFICATION OF THE PROGRAM * * BY H.BURZLAFF & A.HOUNTAS, J. APPL. CRYST. 15 (1982) 464-467 * * VERSION 1995 * ************************************************************************ SUBROUTINE SPGR(NCHA,KS,IERR) COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT CHARACTER NCHA(80),NT(16),NV(12),H(31) CHARACTER*4 TEXB(9),TX(6,3) CHARACTER*2 NTEX(42),CGES(3,3,21) DIMENSION LAT(63),ITL(3,3),ISS(3),KSS(3,3),LS(48,3,3),MTS(3,3), * NSV(3,18),NSW(3),NET(3),NES(3),IN(13),NTS(48,3),NCH(31), * IGET(3,13),NGES(3,3,21),T(3,48),iir(3,3,48) DATA NTEX/ 2H ,2H ,2H 0,2H 0,2H 0,2H 0,2H+1,2H/8,2H+1,2H/6, * 2H 0,2H 0,2H+1,2H/4,2H 0,2H 0,2H+1,2H/3,2H+3,2H/8, * 2H 0,2H 0,2H 0,2H 0,2H+1,2H/2,2H 0,2H 0,2H 0,2H 0, * 2H 0,2H 0,2H+2,2H/3,2H 0,2H 0,2H+3,2H/4,2H 0,2H 0, * 2H+5,2H/6/ DATA TEXB/ 4H -Z,4H -Y,4H X-Y,4H -X,4H 0.0, * 4H X,4H Y-X,4H Y,4H Z/ ,NV/12*1H0/ DATA H/1H ,1H-,1H/,1H0,1H1,1H2,1H3,1H4,1H5,1H6,1HA,1HB,1HC,1HI,1HR * ,1HF,1HP,1HD,1HM,1HN,1HY,1H:,1HE,1HU,1HO,1HG,1HQ,1HT,1HL,1HH,1HX/ C ALL DIGITAL NUMBER BELOW ARE ASCII CODES FOR EACH CHARACTER ABOVE DATA NCH/ 32,45,47,48,49,50,51,52,53,54,65,66,67,73,82, * 70,80,68,77,78,89,58,69,85,79,71,81,84,76,72,88/ C DATA NGES/1,3*0,1,3*0,1,-1,3*0,-1,3*0,1,0,1,0,2*-1,3*0,1,0,1,0,-1, *4*0,1,0,1,3*0,2*1,2*0,2*1,0,-1,4*0,1,-1,3*0,-1,3*0,-1,1,3*0,1,3*0, * -1,0,-1,0,2*1,3*0,-1,0,-1,0,1,4*0,2*-1,3*0,1,3*0,3*-1,0,1,4*0,-1, *1,3*0,-1,3*0,1,0,1,0,1,4*0,-1,0,-1,0,-1,4*0,2*1,2*0,2*-1,3*0,2*-1, *2*0,2*1,3*0,1,-1,3*0,1,3*0,1,0,1,0,1,4*0,2*1,3*0,-1,3*0,-1,0,-1,0, *-1,4*0,-1/ DATA CGES/2H 1,2H 0,2H 0,2H 0,2H 1,2H 0,2H 0,2H 0,2H 1,2H-1, * 2H 0,2H 0,2H 0,2H-1,2H 0,2H 0,2H 0,2H 1,2H 0,2H 1,2H 0, * 2H-1,2H-1,2H 0,2H 0,2H 0,2H 1,2H 0,2H 1,2H 0,2H-1,2H 0, * 2H 0,2H 0,2H 0,2H 1,2H 0,2H 1,2H 0,2H 0,2H 0,2H 1,2H 1, * 2H 0,2H 0,2H 1,2H 1,2H 0,2H-1,2H 0,2H 0,2H 0,2H 0,2H 1, * 2H-1,2H 0,2H 0,2H 0,2H-1,2H 0,2H 0,2H 0,2H-1,2H 1,2H 0, * 2H 0,2H 0,2H 1,2H 0,2H 0,2H 0,2H-1,2H 0,2H-1,2H 0,2H 1, * 2H 1,2H 0,2H 0,2H 0,2H-1,2H 0,2H-1,2H 0,2H 1,2H 0,2H 0, * 2H 0,2H 0,2H-1,2H-1,2H 0,2H 0,2H 0,2H 1,2H 0,2H 0,2H 0, * 2H-1,2H-1,2H-1,2H 0,2H 1,2H 0,2H 0,2H 0,2H 0,2H-1,2H 1, * 2H 0,2H 0,2H 0,2H-1,2H 0,2H 0,2H 0,2H 1,2H 0,2H 1,2H 0, * 2H 1,2H 0,2H 0,2H 0,2H 0,2H-1,2H 0,2H-1,2H 0,2H-1,2H 0, * 2H 0,2H 0,2H 0,2H 1,2H 1,2H 0,2H 0,2H-1,2H-1,2H 0,2H 0, * 2H 0,2H-1,2H-1,2H 0,2H 0,2H 1,2H 1,2H 0,2H 0,2H 0,2H 1, * 2H-1,2H 0,2H 0,2H 0,2H 1,2H 0,2H 0,2H 0,2H 1,2H 0,2H 1, * 2H 0,2H 1,2H 0,2H 0,2H 0,2H 0,2H 1,2H 1,2H 0,2H 0,2H 0, * 2H-1,2H 0,2H 0,2H 0,2H-1,2H 0,2H-1,2H 0,2H-1,2H 0,2H 0, * 2H 0,2H 0,2H-1/ DATA IGET/ 3*0,12,3*0,12,3*0,12,0,3*12,0,3*12,0, * 3*12,0,3*6,0,3*6,0,3*6,18,2*6/ DATA NSV/ 6,3*0,6,3*0,6,2*0,4,2*0,8,2*9,0,5*6,0,6,18,0,6,18,3,6, * 18,2*6,18,9,12,6,9,0,12,0,0,18,4*0,18,4*6,18/ DATA LAT/ 0,0,0,0,0,0,0,0,0,0,12,12,0,0,0,0,0,0,12,0,12,0,0,0, * 0,0,0,12,12,0,0,0,0,0,0,0,12,12,12,0,0,0,0,0,0, * 0,12,12,12,0,12,12,12,0,16,8,8,8,16,16,0,0,0/ DATA ICENT/0/, JN/2/,JM/ 0/,JP/0/,NSQ/0/,NN/0/,INTJ/0 /,INVJ/0/, * IIS /1/,ISYS/2/,IR/-1/,NG/0/, NS/1/,JS/1/, JR/-1/, KL/0/, * NSS/-1/,MS/16/ C 300 FORMAT((22X,I2,1H.,3X,2(A4,2A2,2X),A4,2A2)) 400 FORMAT(/13H SPACE GROUP:,18X,16A1) C 500 FORMAT(/16H SYMMETRY CLASS:,15X,16A1) 600 FORMAT(/13H SPACE GROUP:,18X,4A1,1H-,12A1) 800 FORMAT(/22H EQUIVALENT POSITIONS:) IERR=1 DO 900 I=1,16 NT(I)=' ' IF (I.GT.13) GO TO 900 IN(I)=0 900 CONTINUE DO 1020 I=1,3 NES(I)=1 NSW(I)=0 DO 1020 J=1,3 MTS(I,J)=0 DO 1010 K=1,48 NTS(K,J)=0 1010 CONTINUE 1020 CONTINUE C TRY TO FIND OUT IF THERE IS THE SIGN '-3' AT THE SECOND C POSITION ON THE RECORD OF AN INPUT WITH SPACE GROUP SYMBOL NCHH=0 ICT=0 ISP=0 DO 1040 I=KS,80 IF (NCHA(I).EQ.H(1)) GO TO 1035 IF (ISP.EQ.0) GO TO 1040 ICT=ICT+1 ISP=0 IF (ICT.NE.2) GO TO 1040 IF (NCHA(I).NE.H(2)) GO TO 1045 IF (NCHA(I+1).NE.H(7)) GO TO 1045 NCHH=I GO TO 1045 1035 ISP=1 1040 CONTINUE C SEPREATE TWO PARTS OF CONTROL CARD 1045 J0=0 DO 1080 I=KS,80 IF (I.EQ.NCHH) GO TO 1080 IF (J0.EQ.2) GO TO 1070 IF (NCHA(I).EQ.H(1)) GO TO 1050 J0=0 GO TO 1060 1050 J0=J0+1 1060 INTJ=INTJ+1 NT(INTJ)=NCHA(I) IF (INTJ.EQ.16) RETURN GO TO 1080 1070 IF (INVJ.GT.12.OR.NCHA(I).EQ.H(1).AND.IIS.EQ.1) GO TO 1080 IIS=2 INVJ=INVJ+1 NV(INVJ)=NCHA(I) 1080 CONTINUE C BEGIN DERIVING DO 1100 I=1,16 IF (JS.LT.14) IN(JS)=NH(NT(I)) IF (NT(I).NE.H(1)) GO TO 1090 JR=JR+1 JS=4*JR+1 1090 JS=JS+1 1100 IF (NT(I).EQ.H(7).OR.NT(I).EQ.H(10)) ISYS=5 IF (IN(2).EQ.NCH(8).OR.IN(2).EQ.NCH(2).AND.IN(3).EQ.NCH(8)) * ISYS=4 IF (IN(6).EQ.NCH(7)) ISYS=6 IF (ISYS.EQ.2.AND.IN(2).GE.NCH(6).AND.IN(6).GE.NCH(6)) * ISYS=3 IF (IN(2).EQ.NCH(5).AND.IN(6).LE.NCH(4).OR.IN(2).EQ.NCH(2).AND. * IN(3).EQ.NCH(5)) ISYS=1 KSYS=ISYS+MAX0(0,ISYS-4) IF (IN(2).EQ.NCH(7).OR.IN(2).EQ.NCH(2).AND.IN(3).EQ.NCH(7)) * KSYS=5 DO 1200 I=1,7 LO=I+10 IF (IN(1).EQ.NCH(LO)) IN(1)=I 1200 CONTINUE LATT=MOD(IN(1),7)+1 IF (LATT.LE.5) PTS=MIN0(2,LATT) IF (LATT.GE.6) PTS=LATT-3 IF (IN(1).EQ.6) LATT=6 IF (IN(1).EQ.5) LATT=7 C DETERMINATION OF MONOCLINIC SETTING. IF (ISYS.NE.2.OR.IN(6).GT.NCH(4)) GO TO 1320 DO 1300 I=2,5 LO=I+4 IN(LO)=IN(I) 1300 IN(I)=0 C SELECTION OF GENERATORS 1320 IF (ISYS.GE.2.AND.ISYS.LE.3) GO TO 1330 C 1. POINT GROUPS 1,-1,3,-3,4,-4,6,-6,4/M,6/M. NET(1)=IN(2)-NCH(4) KL=24*(IN(3)-NCH(4))/NET(1) IF (IN(2).EQ.NCH(2)) NET(1)=IN(3)-NCH(4)+6 IF (NET(1).GT.2.AND.NET(1).LT.7.AND.IN(3).GT.NCH(4)) * MTS(1,3)=KL IF (IN(6).LE.NCH(4).OR.IN(2).EQ.NCH(7).OR.IN(2).EQ.NCH(2).AND. 1 IN(3).EQ.NCH(7)) NG=1 IF (IN(6).GT.NCH(4)) GO TO 1330 IF (IN(4).LT.NCH(3)) GO TO 1400 NET(2)=8 IF (IN(5).EQ.NCH(11).OR.IN(4).EQ.NCH(11)) NES(2)=2 IF (IN(5).EQ.NCH(20).OR.IN(4).EQ.NCH(20)) NES(2)=7 NG=2 IF (IN(6).LE.NCH(4)) GO TO 1400 C 2. MONOCLINIC-ORTHORHOMBIC. 1330 DO 1390 I=1,3 DO 1390 J=1,4 L=1+4*(I-1)+J M=L+4 IF (M.GT.13) M=M-12 IF (ISYS.GT.3) GO TO 1350 IF (IN(L).NE.NCH(6).OR.IN(M).GE.NCH(11)) GO TO 1340 NG=NG+1 NET(NG)=29-9*I LO=L+1 IF (IN(LO).EQ.NCH(5)) NES(NG)=I+1 IF (NG.EQ.2.AND.IN(11).EQ.NCH(5)) MTS(2,3)=12 IF (NG.EQ.2) GO TO 1400 1340 IF (IN(L).LE.NCH(10)) GO TO 1390 NG=NG+1 NET(NG)=23-5*I IF (IN(L).GE.NCH(11).AND.IN(L).LE.NCH(13)) * NES(NG)=IN(L)-NCH(11)+2 IF (IN(L).EQ.NCH(20)) NES(NG)=I+4 IF (IN(L).EQ.NCH(18)) NES(NG)=I+8 IF (ISYS.LT.4) GO TO 1390 C 3. TETRAGONAL-HEXAGONAL-CUBIC. 1350 IF (IN(M).LE.NCH(5)) GO TO 1390 IF (I.EQ.3.AND.(ISYS.LT.6.AND.IN(4).LT.NCH(3).OR.ISYS.EQ.6.AND. * IN(2).LE.NCH(10).AND.IN(10).GT.NCH(4))) GO TO 1390 NG=NG+1 IF (NG.EQ.4) NG=3 IF (I.NE.1) GO TO 1360 IF (ISYS.EQ.6) NET(1)=5 IF (IN(6).EQ.NCH(6)) NET(NG)=36-4*ISYS IF (IN(6).GE.NCH(11)) NET(NG)=22-ISYS IF (IN(7).EQ.NCH(5)) NES(1)=2 1360 IF (I.NE.2) GO TO 1370 IF (IN(10).EQ.NCH(6)) NET(NG)=21 IF (IN(10).GE.NCH(11)) NET(NG)=19 IF (NET(1).EQ.5.AND.IN(10).EQ.NCH(6)) NET(2)=14 IF (IN(2).EQ.NCH(2).AND.NET(1).EQ.5) NET(2)=15 1370 IF (IN(M).GE.NCH(11).AND.I.EQ.3) NET(NG)=8 IF (IN(M).EQ.NCH(6).AND.I.EQ.3) NET(NG)=2 IF (IN(2).EQ.NCH(6).AND.IN(3).EQ.NCH(5)) NES(2)=6 IF (IN(6).EQ.NCH(6).AND.IN(10).EQ.NCH(6).AND.I.EQ.1.AND. * IN(3).GT.NCH(4)) MTS(2,3)=24-MTS(1,3) IF (IN(2).NE.NCH(7)) MTS(1,3)=0 DO 1380 II=1,3 IF (NET(2).EQ.14.AND.IN(3).GT.NCH(4)) * MTS(2,II)=48-3*KL+(2*KL-24)*II 1380 IF (NET(2).EQ.14.AND.IN(3).GT.NCH(4)) MTS(2,3)=MTS(2,2) IF (IN(M).GE.NCH(11).AND.IN(M).LE.NCH(13)) * NES(NG)=IN(M)-NCH(11)+2 IF (IN(M).EQ.NCH(20)) NES(NG)=4+I IF (IN(M).EQ.NCH(20).AND.I.EQ.2) NES(NG)=8 IF (IN(M).EQ.NCH(18)) NES(NG)=14-I IF (IN(10).EQ.NCH(18).AND.NET(1).EQ.5) NES(2)=13 IF (NES(2).EQ.13.AND.IN(2).EQ.NCH(11)) NES(2)=12 1390 CONTINUE C COMPLETE SYMMETRY OPERATIONS. 1400 DO 1410 K=1,NG NESK=NES(K) NETK=NET(K) DO 1410 I=1,3 NTS(K,I)=IGET(I,NESK)+MTS(K,I) DO 1410 J=1,3 LS(K,I,J)=NGES(I,J,NETK) 1410 CONTINUE K=0 1420 K=K+1 IF (K.GT.NG) GO TO 1560 L=1 IF (LS(K,1,1)+LS(K,2,2)+LS(K,3,3).EQ.-3) NSS=K IF (LS(K,1,1)+LS(K,2,2)+LS(K,3,3).EQ.3) NU=K 1430 IF (L.GT.NG) GO TO 1420 DO 1450 I=1,3 ITN=NTS(K,I) DO 1450 J=1,3 N=0 ITN=ITN+LS(K,I,J)*NTS(L,J) DO 1440 M=1,3 N=N+LS(K,I,M)*LS(L,M,J) 1440 CONTINUE ITN=MOD(ITN,24) IF (ITN.LT.0) ITN=ITN+24 KSS(I,J)=N ISS(I)=ITN 1450 CONTINUE DO 1470 KK=1,NG N=0 DO 1460 I=1,3 DO 1460 J=1,3 1460 IF (KSS(I,J).NE.LS(KK,I,J)) N=1 IF (N.EQ.0) GO TO 1490 1470 CONTINUE NG=NG+1 DO 1480 I=1,3 NTS(NG,I)=ISS(I) DO 1480 J=1,3 1480 LS(NG,I,J)=KSS(I,J) 1490 L=L+1 IF (K.NE.NSS) GO TO 1550 DO 1540 I=1,3 J=I+1 IK=I+2 IM=I+4 IF (J.GT.3) J=J-3 IF (IK.GT.3) IK=IK-3 IF (IN(1).NE.4) GO TO 1510 IF (I.GT.1) GO TO 1540 IF (NTS(NSS,1).GE.12.AND.NTS(NSS,2).GE.12.AND.NTS(NSS,3).GE.12) * NN=1 IF (NN.NE.1) GO TO 1540 DO 1500 IJ=1,3 1500 NTS(NSS,IJ)=NTS(NSS,IJ)-12 1510 NN=0 IF (IN(1).EQ.6) GO TO 1520 IF (IN(1).NE.I) GO TO 1540 1520 IF (NTS(NSS,J).GE.12.AND.NTS(NSS,IK).GE.12) NN=1 IF (NN.NE.1) GO TO 1540 DO 1530 II=1,3 NTS(NSS,II)=NTS(NSS,II)-IGET(II,IM) 1530 CONTINUE 1540 CONTINUE 1550 GO TO 1430 C DETERMINE CENTROSYMMETRY AND SHIFT VECTOR TO A CENTRE OF SYMM.. 1560 IF (NSS.GT.0) NS=0 IF (NS.EQ.0) ICENT=1 DO 1570 I=1,3 1570 MTS(1,I)=0 IF (NS.EQ.1) GO TO 1590 DO 1580 K=1,3 MTS(1,K)=NTS(NSS,K)/2 MTS(1,K)=MOD(MTS(1,K),24) IF (MTS(1,K).LT.0) MTS(1,K)=MTS(1,K)+24 1580 CONTINUE C DETERMINE THE REF, NUMBER OF SHIFT VECTOR TO AN ORIGIN OF I. T.. 1590 IF (IIS.EQ.2) GO TO 1650 NSQ=1 DO 1600 I=1,13 1600 IF (IN(I).EQ.NCH(1).OR.IN(I).EQ.0) IN(I)=NCH(4) IF (ISYS.LT.3.OR.IN(4).NE.NCH(4).OR.ISYS.GT.4) GO TO 1630 IF (ISYS.NE.3) GO TO 1610 IF ((IN(3)+IN(7))/2.GT.NCH(4)) MS=8-6*(IN(11)-NCH(4)) IF ((IN(6).EQ.NCH(11).OR.(IN(2)+IN(6))/2.EQ.NCH(20)) * .AND.IN(10).EQ.NCH(6)) MS=8 IF (MS.EQ.8.AND.(IN(2).EQ.NCH(19).OR.IN(2).EQ.NCH(13))) MS=1 IF (IN(1).EQ.3.AND.IN(2).EQ.NCH(19).AND.IN(10).EQ.NCH(11)) MS=8 IF ((IN(2).EQ.NCH(20).OR.IN(2).EQ.NCH(12)).AND. * (IN(6).EQ.NCH(13).OR.IN(6).EQ.NCH(19)).AND.IN(10).EQ.NCH(6)) * MS=2 IF (IN(1).EQ.4.AND.IN(10).EQ.NCH(11)) MS=7 IF (IN(6).EQ.NCH(18).AND.IN(10).EQ.NCH(6)) MS=6 GO TO 1680 1610 IF (IN(1).EQ.4.AND.IN(3).EQ.NCH(5)) MS=9 IF ((IN(6)+IN(10))/2.EQ.NCH(6).AND. * (IN(3)-NCH(4)+1)/2.GT.(IN(3)-NCH(4))/2) MS=3 IF (MS.EQ.3.AND.IN(1).EQ.4) MS=12 DO 1620 I=1,4 1620 IF (IN(7).EQ.NCH(5).AND.IN(3).EQ.NCH(I+3)) MS=8+I IF (IN(10).EQ.NCH(13).AND.IN(6).EQ.NCH(6)) MS=3+8*(IN(7)-NCH(4)) IF (IN(7).EQ.NCH(5).AND.IN(10).EQ.NCH(19).OR.IN(10).EQ.NCH(18)) * MS=13-4*(IN(7)-NCH(4)) IF (IN(6).EQ.NCH(12).OR.IN(6).EQ.NCH(13).AND.IN(2).EQ.NCH(2)) * MS=8-5*(IN(6)-NCH(12)) IF (IN(6).EQ.NCH(20)) MS=9-(IN(3)-NCH(4))/2 IF (IN(6).EQ.NCH(12).AND.IN(10).GE.NCH(11).OR. * IN(6).EQ.NCH(13).AND.IN(10).EQ.NCH(18)) * MS=9-7*(IN(6)-NCH(12)) IF (IN(6).EQ.NCH(19).AND.IN(10).EQ.NCH(18).OR.IN(6).EQ.NCH(13) * .AND.IN(10).EQ.NCH(19)) MS=14+IN(3)-NCH(4) 1630 IF (ISYS.NE.4) GO TO 1640 IF (IN(6).EQ.NCH(12).OR.IN(1).EQ.4.AND.IN(6).EQ.NCH(13)) MS=14 IF (IN(5).EQ.NCH(20).AND.(IN(6).EQ.NCH(4).OR.IN(6).EQ.IN(5)).OR. * IN(4).EQ.NCH(20).AND.IN(6).EQ.IN(4)) MS=14 IF (IN(5).EQ.NCH(11).AND.IN(6).GT.NCH(10)) * MS=18-((IN(6)-NCH(13))/10) 1640 IF (IN(2).EQ.NCH(7).AND.IN(3).NE.NCH(4).AND.IN(6).NE.NCH(4)) * MS=IN(3)-NCH(4)+3 IF (IN(1).EQ.6.AND.IN(3).EQ.NCH(5).OR.IN(1).EQ.4.AND. * IN(2).EQ.NCH(11)) MS=7 IF (IN(4).EQ.NCH(19).AND.IN(6).EQ.NCH(20)) MS=14 GO TO 1680 C SHIFT TO ANOTHER ORIGIN. 1650 DO 1660 I=1,12 IF (JN.LT.14) IN(JN)=NH(NV(I)) IF (NV(I).NE.H(1)) GO TO 1655 JM=JM+1 JN=4*JM+1 1655 JN=JN+1 1660 CONTINUE DO 1670 I=1,9,4 JP=JP+1 IO=I+1 LO=I+3 IF (IN(LO).NE.NCH(4)) NSW(JP)=(IN(IO)-NCH(4))*24/ * (IN(LO)-NCH(4)) 1670 CONTINUE C APPLY THE SHIFT OF ORIGIN TO ALL OPERATIONS. 1680 IF (NS.EQ.1.AND.IIS.EQ.0) GO TO 1730 DO 1690 K=1,3 IF (IIS.NE.1) NSV(K,MS)=0 NSW(K)=NSV(K,MS)+MTS(1,K)+NSW(K) NSW(K)=MOD(NSW(K),24) IF (NSW(K).LT.0) NSW(K)=NSW(K)+24 1690 CONTINUE DO 1720 I=1,NG DO 1720 J=1,3 L=NTS(I,J) DO 1700 K=1,3 L=L-(LS(NU,J,K)-LS(I,J,K))*NSW(K) 1700 CONTINUE 1710 IF (L.LT.24.AND.L.GE.0) GO TO 1715 IF (L.LT.0) L=L+24 IF (L.GE.24) L=L-24 GO TO 1710 1715 NTS(I,J)=L 1720 CONTINUE C NORMALIZATION OF CENTRING TYPE. 1730 DO 1780 I=1,NG DO 1780 J=1,3 NN=0 K=J+1 KI=J+2 IF (K.GT.3) K=K-3 IF (KI.GT.3) KI=KI-3 IF (IN(1).NE.4) GO TO 1750 IF (J.GT.1) GO TO 1780 IF (NTS(I,1).GE.12.AND.NTS(I,2).GE.12.AND.NTS(I,3).GE.12) NN=1 IF (NN.NE.1) GO TO 1780 DO 1740 IJ=1,3 1740 NTS(I,IJ)=NTS(I,IJ)-12 1750 IF (IN(1).EQ.6) GO TO 1760 IF (IN(1).NE.J) GO TO 1780 1760 IF (NTS(I,K).GE.12.AND.NTS(I,KI).GE.12) NN=1 IF (NN.NE.1) GO TO 1780 DO 1770 II=1,3 JI=J+4 NTS(I,II)=NTS(I,II)-IGET(II,JI) 1770 CONTINUE 1780 CONTINUE C OUTPUT ON LINE-PRINTER. C IF (ISYS.EQ.1) WRITE (6,500) H(28),H(15),H(14),H(13),H(29), C 1 H(14),H(20),H(14),H(13) C IF (ISYS.EQ.2) WRITE (6,500) H(19),H(25),H(20),H(25),H(13), C 1 H(29),H(14),H(20),H(14),H(13) C IF (ISYS.EQ.3) WRITE (6,500) H(25),H(15),H(28),H(30),H(25), C 1 H(15),H(30),H(25),H(19),H(12),H(14),H(13) C IF (ISYS.EQ.4) WRITE (6,500) H(28),H(23),H(28),H(15),H(11), C 1 H(26),H(25),H(20),H(11),H(29) C IF (ISYS.EQ.5) WRITE (6,500) H(30),H(23),H(31),H(11),H(26), C 1 H(25),H(20),H(11),H(29) C IF (ISYS.EQ.6) WRITE (6,500) H(13),H(24),H(12),H(14),H(13) IF (NCHH.EQ.0) WRITE (6,400) NT IF (NCHH.NE.0) WRITE (6,600) NT C LOOK FOR 'X,Y,Z' OPERATION DO 1790 I=1,NG IZER=IABS(NTS(I,1))+IABS(NTS(I,2))+IABS(NTS(I,3)) IF (IZER.NE.0) GO TO 1790 IZER=IABS(LS(I,1,2))+IABS(LS(I,1,3))+IABS(LS(I,2,3))+ * IABS(LS(I,2,1))+IABS(LS(I,3,1))+IABS(LS(I,3,2)) IF (IZER.NE.0) GO TO 1790 IF (LS(I,1,1).EQ.1.AND.LS(I,2,2).EQ.1.AND.LS(I,3,3).EQ.1) * GO TO 1800 1790 CONTINUE RETURN C PRINT SYMMTRICAL SYMBOLS 1800 IF (LATT.EQ.1) WRITE (6,800) IF (LATT.EQ.2) WRITE (6,1810) 1810 FORMAT(/22H EQUIVALENT POSITIONS:,8X,20H+(0 0 0 0 1/2 1/2)/) IF (LATT.EQ.3) WRITE (6,1820) 1820 FORMAT(/22H EQUIVALENT POSITIONS:,8X,20H+(0 0 0 1/2 0 1/2)/) IF (LATT.EQ.4) WRITE (6,1830) 1830 FORMAT(/22H EQUIVALENT POSITIONS:,8X,20H+(0 0 0 1/2 1/2 0)/) IF (LATT.EQ.5) WRITE (6,1840) 1840 FORMAT(/22H EQUIVALENT POSITIONS:,8X,22H+(0 0 0 1/2 1/2 1/2)/) IF (LATT.EQ.6) WRITE (6,1850) 1850 FORMAT(/22H EQUIVALENT POSITIONS:,8X,22H+(0 0 0 0 1/2 1/2 , 1 22H1/2 0 1/2 1/2 1/2 0)/) IF (LATT.EQ.7) WRITE (6,1860) 1860 FORMAT(/22H EQUIVALENT POSITIONS:,8X,22H+(0 0 0 2/3 1/3 1/3 , 1 14H 1/3 2/3 2/3)/) ML=(LATT-1)*9+1 DO 1880 LL=1,3 ITL(LL,1)=LAT(ML) ITL(LL,2)=LAT(ML+1) ITL(LL,3)=LAT(ML+2) ML=ML+3 1880 CONTINUE I0=I-1 IR=I0-1 JJ=0 1890 IR=MOD(NG+IR+1,NG)+1 IE=MOD(NG+IR,NG)+1 DO 1900 I1=1,2 JJ=JJ+1 I=IR IF (I1.EQ.2) I=IE IU=I DO 1900 J=1,3 MO=LS(I,J,1)+LS(I,J,2)*3+LS(I,J,3)*4+5 TX(J,I1)=TEXB(MO) DO 1900 K=1,2 LO=2*NTS(I,J)+K CGES(K,J,I1)=NTEX(LO) 1900 CONTINUE C 300 FORMAT((22X,I2,1H.,3X,2(A4,2A2,2X),A4,2A2)) JJ1=JJ-1 IF (JJ.LE.NG) WRITE (6,300) JJ1,TX(1,1),(CGES(I,1,1),I=1,2), * TX(2,1),(CGES(I,2,1),I=1,2),TX(3,1),(CGES(I,3,1),I=1,2), * JJ,TX(1,2),(CGES(I,1,2),I=1,2), * TX(2,2),(CGES(I,2,2),I=1,2),TX(3,2),(CGES(I,3,2),I=1,2) IF (JJ.GT.NG) WRITE (6,300) JJ1,TX(1,1),(CGES(I,1,1),I=1,2), * TX(2,1),(CGES(I,2,1),I=1,2),TX(3,1),(CGES(I,3,1),I=1,2) C IF (JJ.LE.NG) WRITE (6,300) JJ1,(TX(J,1),(CGES(I,J,1),I=1,2), C * J=1,3),JJ,(TX(J,2),(CGES(I,J,2),I=1,2),J=1,3) C IF (JJ.GT.NG) WRITE (6,300) JJ1,(TX(J,1), C * (CGES(I,J,1),I=1,2),J=1,3) IF (JJ.LT.NG) GO TO 1890 IF (ICENT.EQ.0) GO TO 1980 C GIVE UP THE CENTROSYMMTRICAL OPERATIONS I1=I0 DO 1970 I=1,NG I1=MOD(I1,NG)+1 IF (LS(I1,1,1).EQ.100) GO TO 1970 DO 1960 J1=1,NG IF (LS(J1,1,1).EQ.100.OR.I1.EQ.J1) GO TO 1960 IZER=0 JZER=0 DO 1920 K1=1,3 IZER=IZER+MOD(IABS(NTS(I1,K1)+NTS(J1,K1)+24),24) DO 1910 L1=1,3 JZER=JZER+IABS(LS(I1,K1,L1)+LS(J1,K1,L1)) IF (JZER.NE.0) GO TO 1960 1910 CONTINUE 1920 CONTINUE IF (IZER.EQ.0) GO TO 1950 DO 1940 K2=1,3 IZER=0 DO 1930 K1=1,3 IZER=IZER+MOD(IABS(NTS(I1,K1)+NTS(J1,K1)+ITL(K2,K1)+24),24) 1930 CONTINUE IF (IZER.EQ.0) GO TO 1950 1940 CONTINUE GO TO 1960 1950 LS(J1,1,1)=100 GO TO 1970 1960 CONTINUE RETURN 1970 CONTINUE C TRANSLATE INTO FORMAT OF PREPAR 1980 J=0 DO 2000 I=1,NG I0=MOD(I0,NG)+1 IF (LS(I0,1,1).EQ.100) GO TO 2000 J=J+1 DO 1990 K=1,3 TS(K,J)=NTS(I0,K)/24.0 DO 1990 L=1,3 IS(L,K,J)=LS(I0,K,L) 1990 CONTINUE 2000 CONTINUE NSYM=J IF (J.NE.NG.AND.J.NE.NG/2) RETURN C OUTPUT THE EXPRESION OF INDEPENDENT HARKER PEAKS CALL HKPKCOM(IIR,T) CALL OUTHKPK(IIR,T) IERR=0 RETURN END C ----------------------------------------------------------------- FUNCTION NH(ICH) DIMENSION NCH(31) CHARACTER H(31),ICH DATA H/1H ,1H-,1H/,1H0,1H1,1H2,1H3,1H4,1H5,1H6,1HA,1HB,1HC,1HI,1HR * ,1HF,1HP,1HD,1HM,1HN,1HY,1H:,1HE,1HU,1HO,1HG,1HQ,1HT,1HL,1HH,1HX/ C THOSE DIGITAL NUMBER BELOW ARE ASCII CODES FOR EACH CHARACTER ABOVE DATA NCH/ 32,45,47,48,49,50,51,52,53,54,65,66,67,73,82, * 70,80,68,77,78,89,58,69,85,79,71,81,84,76,72,88/ DO 200 I=1,31 IF (ICH.EQ.H(I)) GO TO 300 200 CONTINUE NH=0 RETURN 300 NH=NCH(I) RETURN END c------------------------------------------------------------------ SUBROUTINE HKPKCOM(IR,T) C PROGRAM FOR DERIVING AND PRINTING HARKER-PEAK POSITIONS C COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT DIMENSION IR(3,3,48),T(3,48) C DO 2030 K=1,48 DO 2020 J=1,3 DO 2010 I=1,3 IR(I,J,K)=0 2010 CONTINUE T(J,K)=0.0 2020 CONTINUE 2030 CONTINUE NPK=NSYM-1 DO 3060 K=1,NPK DO 3040 J=1,3 DO 3020 I=1,3 IR(I,J,K)=IS(I,J,1)-IS(I,J,K+1) IF (ICENT.EQ.1) IR(I,J,NPK+K)=IS(I,J,1)+IS(I,J,K+1) 3020 CONTINUE T(J,K)=TS(J,1)-TS(J,K+1) IF (ICENT.EQ.1) T(J,NPK+K)=TS(J,1)+TS(J,K+1) 3040 CONTINUE 3060 CONTINUE IF (ICENT.EQ.1) THEN IR(1,1,2*NPK+1)=2 IR(2,2,2*NPK+1)=2 IR(3,3,2*NPK+1)=2 ENDIF RETURN END C------------------------------------------------------------------ SUBROUTINE OUTHKPK(IR,T) COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT DIMENSION IR(3,3,48),T(3,48) CHARACTER*1 STG(30),NB(10),XYZ(3) DATA NB/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/ DATA XYZ/1HX,1HY,1HZ/ WRITE (6,3000) 3000 FORMAT (/1X,'INDEPENDENT POSITIONS OF HARKER PEAK:'/ 1 31X,'U',9X,'V',9X,'W'/ 1 26X,'-------------------------------') NPK=(ICENT+1)*NSYM-1 DO 4000 K=1,NPK DO 3070 II=1,30 STG(II)=' ' 3070 CONTINUE DO 3100 J=1,3 II=(J-1)*10+1 MARK=0 DO 3080 I=1,3 IF (IR(I,J,K).EQ.0) GO TO 3080 IF (IR(I,J,K).GT.0) THEN IF (MARK.EQ.0) STG(II)=' ' IF (MARK.EQ.1) STG(II)='+' II=II+1 ELSE STG(II)='-' II=II+1 ENDIF MARK=1 IF (IABS(IR(I,J,K)).GT.1) THEN STG(II)=NB(IABS(IR(I,J,K))+1) II=II+1 ENDIF STG(II)=XYZ(I) II=II+1 3080 CONTINUE IF (ABS(T(J,K)).LT.0.001) GOTO 3092 TT=T(J,K) IF (TT.LT.0.0) TT=AMOD(TT+2.0,1.0) BOT=1.0/TT DO 3084 N=1,9 IF (AMOD(N*BOT,1.0).LT.0.01) GOTO 3090 3084 CONTINUE 3090 IF (MARK.EQ.1) THEN STG(II)='+' ELSE STG(II)=' ' ENDIF STG(II+1)=NB(N+1) STG(II+2)='/' STG(II+3)=NB(INT(N*BOT)+1) MARK=1 3092 IF (MARK.EQ.0) THEN STG(II)=' ' STG(II+1)='0' ENDIF 3100 CONTINUE WRITE (6,3200) K,STG 3200 FORMAT(22X,I2,'.',5X,30A1) 4000 CONTINUE RETURN END C----------------------------------------------------------------------- SUBROUTINE VOL(CX,V) C SINE AND COSINE OF CELL ANGLES PLUS TRIGONOMETRIC PART OF VOLUME COMMON/UNIT1/ITLE(80),LIST,PI DIMENSION CX(9) CHARACTER ITLE DTOR=PI/180.0 ARG=1.0 DO 10 I=4,6 CX(I+3)=SIN(DTOR*CX(I)) CX(I)=COS(DTOR*CX(I)) ARG=ARG-CX(I)*CX(I) 10 CONTINUE V=SQRT(ARG+2.0*CX(4)*CX(5)*CX(6)) RETURN END ************************************************************************ * * * W W IIIII L SSSSS OOOOO N N * * W W I L S S O O NN N * * W W I L S O O N N N * * W W I L SSSSS O O N N N * * W W W I L S O O N N N * * W W W W I L S S O O N NN * * W W IIIII LLLLLL SSSSS OOOOO N N * * * * WILSON STATISTICS * * A MODIFICATION OF THE SUBROUTINE 'SUM' OF MULTAN-80 * * VERSON 1995 * ************************************************************************ SUBROUTINE WILSONN(MH,MK,ML,MISS,BTT) COMMON/ATMGROUP/NINF(10) COMMON/REFLXIN/LH(600),LK(600),LL(600),FO(600),ID(600),RHO(600), 1 SIG(600),XKP(600) COMMON/RESCALING/ISC,IBGR,MG,MIG(8),SCL,BT(9),SC(9),IP(8,3,5), 1 SCAL(8) COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT, 1 IAVE,EXTI COMMON/UNIT1/ITLE(80),LIST,PI COMMON/WILSON/FLGW(30,9),FLGD(30,9),AVR(30,9),DCV(50,9),SLOPE(9), 1 FLGK(9),DEL(9),KS(9),EW(600),ED(600),EDP(600) COMMON/XXX/P(6),CX(9),NREF,NB,RHOMAX,MM,EMAX,EN,MZ,ER,ISIM,RHOCUT, 1 RHOMIN,RHOLOW,ENG(8),ERG(8),KNOWN,IPATH,VOLUME DIMENSION SW(30,9),SD(30,9),SR(30,9),SI(30,9),FMIN(30,9) DIMENSION NSUM(30,9),NSUMT(30),IHKL(3) CHARACTER ITLE IF (IBGR.EQ.0.OR.ISC.EQ.2) GO TO 80 IF (KSYS.LE.3) WRITE (6,20) 20 FORMAT(/1X,10X,11HINDEX GROUP 1,47H 1 2 3 4 5 6 7 8 2/25X,45HEEE OEE EOE OOE EEO OEO EOO OOO) IF (KSYS.EQ.4) WRITE (6,30) 30 FORMAT(/1X,13X,11HINDEX GROUP 1,43H 1 2 3 4 5 6 2/28X,41HEEE EOE,OEE OOE EEO EOO,OEO OOO) IF (KSYS.LE.4) GO TO 80 WRITE (6,40) 40 FORMAT(/1X,25HINDEX GROUPS DIVIDED ON -) IF (KSYS.LE.6) WRITE (6,50) 50 FORMAT(10X,11HH: MOD(H,3),4X,11HK: MOD(K,3),4X, 1 13HI: MOD(H+K,3),4X,11HL: MOD(L,2)) IF (KSYS.EQ.7) WRITE (6,60) 60 FORMAT(10X,13H1: MOD(H-L,3),4X,13H2: MOD(K-L,3),4X, 1 13H3: MOD(H-K,3),4X,15H4: MOD(H+K+L,2)) WRITE (6,70) 70 FORMAT(/10X,11HINDEX GROUP 1,50H 1 2 3 4 5 6 2/25X,49HOOOE OOEE,OEOE EEEE OOOO OOEO,OEOO EEEO/ 3 10X,18HE - ZERO REMAINDER,4X,22HO - NON-ZERO REMAINDER) 80 M=MG+1 IF (IBGR.EQ.0) M=1 IF (MISS.EQ.0) GO TO 115 NUMB=0 NEXT=0 DO 110 IH=1,2*MH+1 IHKL(1)=IH-MH-1 DO 100 IK=1,2*MK+1 IHKL(2)=IK-MK-1 DO 90 IL=1,2*ML+1 IHKL(3)=IL-ML-1 IF (IHKL(1).EQ.0.AND.IHKL(2).EQ.0.AND.IHKL(3).EQ.0) GO TO 90 NUMB=NUMB+1 IEXT = 0 CALL REJECT(IEXT,IHKL) IF (IEXT.EQ.0) GO TO 90 NEXT=NEXT+1 90 CONTINUE 100 CONTINUE 110 CONTINUE RATE=1.0-FLOAT(NEXT)/NUMB 115 DO 350 K=1,M IF (K.LT.M) THEN WRITE (6,130) K 130 FORMAT(//1X,40HDETERMINE B VALUE AND SCALING FACTOR FOR, 1 3X,12H INDEX GROUP,I3) ELSE WRITE (6,140) 140 FORMAT(//1X,40HDETERMINE B VALUE AND SCALING FACTOR FOR, 1 3X,15H ALL REFLEXIONS) ENDIF WRITE (6,160) 160 FORMAT(/44X,'EXP(-2*B*RHO)*E**2'/ 1 6H RANGE,2X,'(SIN/LAM)**2',2X,6HNUMBER,2X,8HMEAN RHO, 2 2X,6HMEAN I,5X,'MEAN',5X,'DEBYE',5X,6HWILSON) C SET INITIAL VALUES PP=0.0 Q=0.0 R=0.0 S=0.0 T=0.0 NUMBER=0 ADD=RHOMAX/FLOAT(NB) START=-ADD END=ADD RR=FLOAT(NB)/RHOMAX DO 170 I=1,30 DO 170 J=1,9 SW(I,J)=0.0 SD(I,J)=0.0 SR(I,J)=0.0 SI(I,J)=0.0 FMIN(I,J)=100000.0 NSUM(I,J)=0 170 CONTINUE REWIND 8 C READ SCRATCH TAPE 180 READ (8) LH,LK,LL,FO,ID,EW,ED,RHO,SIG,EDP DO 200 I=1,600 C TAPE ENDS WITH FO .LT. 0.0 IF (FO(I).LT.0.0) GO TO 210 C N STORES RANGE OF RHO N=MIN0(INT(1.0+RR*RHO(I)),NB) IG=MOD(ID(I),100) IF (IBGR.EQ.0) IG=1 MULT=ID(I)/10000 IE=(ID(I)-10000*MULT)/100 EPS=FLOAT(IE) TMUL=FLOAT(MULT) C WEIGHTED SUMS C NUMBER OF REFLEXIONS NSUM(N,IG)=NSUM(N,IG)+MULT C WILSON SW(N,IG)=SW(N,IG)+EW(I)*TMUL C DEBYE IF (KNOWN.EQ.0) SD(N,IG)=SD(N,IG)+ED(I)*TMUL IF (KNOWN.EQ.1) SD(N,IG)=SD(N,IG)+EDP(I)*TMUL C RHO SR(N,IG)=SR(N,IG)+RHO(I)*TMUL C INTENSITY IF (FO(I).LT.FMIN(N,IG)) FMIN(N,IG)=FO(I) SI(N,IG)=SI(N,IG)+TMUL*FO(I)*FO(I)/(EPS*PTS) 200 CONTINUE GO TO 180 210 IF (IBGR.EQ.0) GO TO 250 DO 230 J=1,NB DO 220 I=1,MG NSUM(J,M)=NSUM(J,M)+NSUM(J,I) SW(J,M)=SW(J,M)+SW(J,I) SD(J,M)=SD(J,M)+SD(J,I) SR(J,M)=SR(J,M)+SR(J,I) SI(J,M)=SI(J,M)+SI(J,I) 220 CONTINUE 230 CONTINUE 250 DO 300 I=1,NB C SMOOTH CURVE BY ADDING ADJACENT RANGES NUMBER=NUMBER+NSUM(I,K) NSUM(I,K)=NSUM(I,K)+NSUM(I+1,K) SW(I,K)=SW(I,K)+SW(I+1,K) SD(I,K)=SD(I,K)+SD(I+1,K) SR(I,K)=SR(I,K)+SR(I+1,K) SI(I,K)=SI(I,K)+SI(I+1,K) C CALCULATE WEIGHTED AVERAGES AND LOGS START=START+ADD END=AMIN1(END+ADD,RHOMAX) IF (MISS.EQ.0.OR.IBGR.NE.0.OR.I.LE.1.OR.I.GE.NB) GO TO 255 NSUMT(I)=VOLUME*2.0944*((2*SQRT(END))**3-(2*SQRT(START))**3)*RATE MTEMP=NSUMT(I)-NSUM(I,K) IF (MTEMP.LE.0) GO TO 255 NSUM(I,K)=NSUMT(I) SI(I,K)=SI(I,K)+MTEMP*FMIN(I,K)/2.0 255 WT=FLOAT(NSUM(I,K)) DIV=1.0/AMAX1(1.0,WT) ESQAV=SD(I,K)*DIV AVI=SI(I,K)*DIV IF (NSUM(I,K).EQ.0) GO TO 260 FLGD(I,K)=ALOG(ESQAV) FLGW(I,K)=ALOG(SW(I,K)*DIV) AVR(I,K)=SR(I,K)*DIV GO TO 270 260 FLGD(I,K)=-20.0 FLGW(I,K)=-20.0 AVR(I,K)=(START+END)/2.0 270 WRITE (6,280) I,START,END,NSUM(I,K),AVR(I,K),AVI,ESQAV,FLGD(I,K), 1 FLGW(I,K) 280 FORMAT(1H ,I3,F8.4,2H -,F6.4,I6,F10.4,F10.1,F9.4,F10.4,F11.4) C COEFFICIENTS OF NORMAL EQUATIONS PP=PP+WT*AVR(I,K)*AVR(I,K) Q=Q+WT*AVR(I,K) R=R+WT*AVR(I,K)*FLGD(I,K) S=S+WT*FLGD(I,K) T=T+WT 300 CONTINUE IF (NUMBER.NE.0) GO TO 310 SC(K)=0.0 GO TO 350 310 WRITE (6,320) PP,Q,R,Q,T,S 320 FORMAT(1X,16HNORMAL EQUATIONS/(1H ,E11.3,10H * SLOPE +,E11.3, 1 14H * INTERCEPT =,E11.3)) C LEAST SQUARES DIV=PP*T-Q*Q SLOPE(K)=(R*T-Q*S)/DIV FLGK(K)=(PP*S-Q*R)/DIV SC(K)=EXP(-FLGK(K)) BT(K)=-0.5*SLOPE(K) WRITE (6,340) SLOPE(K),FLGK(K),BT(K),SC(K) 340 FORMAT(/1X,6HSLOPE=,F7.3,1X,10HINTERCEPT=,F6.3,2X, 1 22HTEMPERATURE FACTOR(B)=,F7.2,1X,6HSCALE=,F7.2/ 2 20X,39HSQRT(SCALE)*F(OBS) = EXP(-B*RHO)*F(CAL)) 350 CONTINUE IF (IBGR.EQ.1) GO TO 370 M=MG+1 DO 360 I=2,M BT(I)=BT(1) 360 CONTINUE RETURN 370 DO 380 I=1,MG SCAL(I)=SC(I) 380 CONTINUE SC(1)=SC(M) RETURN END C ------------ SUBROUTINE GRAPH(NGP) C LINE PRINTER PLOT AT 50 VALUES OF RHO COMMON/RESCALING/ISC,IBGR,MG,MIG(8),SCL,BT(9),SC(9),IP(8,3,5), 1 SCAL(8) COMMON/UNIT1/ITLE(80),LIST,PI,KCURV COMMON/WILSON/FLGW(30,9),FLGD(30,9),AVR(30,9),DCV(50,9),SLOPE(9), 1 FLGK(9),DEL(9),KS(9),EW(600),ED(600),EDP(600) COMMON/XXX/P(6),CX(9),NREF,NB,RHOMAX,MM,EMAX,EN,MZ,ER,ISIM,RHOCUT, 1 RHOMIN,RHOLOW,ENG(8),ERG(8),KNOWN,IPATH,VOLUME DIMENSION FH(6),RH(6),M(117),R(4),AD(4),AW(4) DATA IST,ISP,ICW,ICD/1H*,1H ,1HW,1HD/ MMGR=MG+1 IF (IBGR.EQ.0) MMGR=1 DO 260 K=1,MMGR C DETERMINE RANGES OF LOGS RX=AVR(NB,K) FX=FLGK(K) FN=SLOPE(K)*RX+FLGK(K) DO 10 I=1,117 M(I)=ISP 10 CONTINUE DO 20 I=1,NB IF (FLGW(I,K).LT.-19.0) GO TO 20 FX=AMAX1(FX,FLGW(I,K),FLGD(I,K)) FN=AMIN1(FN,FLGW(I,K),FLGD(I,K)) 20 CONTINUE FD=FX-FN DO 30 I=1,6 RH(I)=0.2*FLOAT(I-1)*RX FH(I)=FN+0.2*FLOAT(I-1)*FD 30 CONTINUE C TOP FRAME J=1 IR=2 DO 200 I=1,50 C SIDE FRAME IF (MOD(I,10).EQ.0) GO TO 60 GO TO 80 60 CONTINUE IR=IR+1 C INTERPOLATION 80 Q=0.02*FLOAT(I)*RX IL=(SLOPE(K)*Q+FLGK(K)-FN)*100.0/FD+16.5 IF (IL.GT.117) IL=117 IF (IL.LT.1) IL=1 M(IL)=IST C STRAIGHT LINE OUTPUT (*) M(IL)=ISP IF (Q.LT.AVR(1,K)) GO TO 180 IF (J.EQ.1) GO TO 90 IF (J.EQ.NB-2) GO TO 130 IF (Q.LT.AVR(J+1,K)) GO TO 130 90 J=J+1 DO 100 KK=1,4 ITEMP = J-2+KK R(KK)=AVR(ITEMP,K) 100 CONTINUE CALL SOLVE(R,FLGW(J-1,K),FLGW(J,K),FLGW(J+1,K),FLGW(J+2,K),AW) IF (NGP.EQ.0) GO TO 130 CALL SOLVE(R,FLGD(J-1,K),FLGD(J,K),FLGD(J+1,K),FLGD(J+2,K),AD) C WILSON PLOT INTERPOLATION 130 IL=100.0*(AW(4)+Q*(AW(3)+Q*(AW(2)+Q*AW(1)))-FN)/FD+16.5 IF (IL.GT.117) IL=117 IF (IL.LT.1) IL=1 M(IL)=ICW C WILSON PLOT OUTPUT (W) M(IL)=ISP IF (NGP.NE.0) GO TO 160 C STORE K-CURVE IF (KCURV.EQ.1) DCV(I,K)=EXP(AW(4)+Q*(AW(3)+Q*(AW(2)+Q*AW(1)))) GO TO 180 C DEBYE CURVE INTERPOLATION 160 IL=100.0*(AD(4)+Q*(AD(3)+Q*(AD(2)+Q*AD(1)))-FN)/FD+16.5 IF (IL.GT.117) IL=117 IF (IL.LT.1) IL=1 M(IL)=ICD C DEBYE CURVE OUTPUT (D) M(IL)=ISP C STORE K-CURVE IF (KCURV.EQ.1) DCV(I,K)=EXP(AD(4)+Q*(AD(3)+Q*(AD(2)+Q*AD(1)))) 180 continue 200 CONTINUE C K-CURVE PARAMETERS DEL(K)=50.0/AVR(NB,K) KS(K)=AVR(1,K)*DEL(K)+1.0 C K-CURVE FOLLOWS LEAST-SQUARES STRAIGHT LINE OR DEBYE CURVE C (WHICHEVER WILL PRODUCE THE SMALLER E'S) UNTIL THE DEBYE C CURVE CROSSES THE L.S. STRAIGHT LINE. J=0 JP=0 KK=KS(K) DO 250 I=KK,50 SK=EXP(SLOPE(K)*FLOAT(I)/DEL(K)+FLGK(K)) JP=-1 IF (DCV(I,K).GT.SK) JP=1 IF (J.EQ.(-JP)) GO TO 260 J=JP IF (JP.EQ.1) GO TO 250 240 DCV(I,K)=SK 250 CONTINUE 260 CONTINUE 270 FORMAT(1H1) RETURN END C ------------------------ SUBROUTINE SOLVE(R,Y1,Y2,Y3,Y4,A) C FIT CURVE TO Y = A(1) * RHO**3 + A(2) * RHO**2 + A(3) * RHO + A(4) DIMENSION R(4),A(4) B2=R(4)*(R(4)+R(1)) B1=(Y4-Y1)/(R(4)-R(1)) C31=(Y2-Y1)/(R(2)-R(1))-B1 C32=(Y3-Y1)/(R(3)-R(1))-B1 C11=R(2)*(R(2)+R(1))-B2 C12=R(3)*(R(3)+R(1))-B2 C21=R(2)-R(4) C22=R(3)-R(4) CMC=C22*C11-C12*C21 IF (ABS(CMC).LE.1.0E-9) A(1)=0.0 IF (ABS(CMC).GT.1.0E-9) A(1)=(C31*C22-C32*C21)/CMC IF (ABS(C21).LE.1.0E-9) A(2)=0.0 IF (ABS(C21).GT.1.0E-9) A(2)=(C31-C11*A(1))/C21 A(3)=B1-(R(4)*R(4)+R(1)*R(1)+R(4)*R(1))*A(1)-(R(4)+R(1))*A(2) A(4)=Y1-R(1)*(A(3)+R(1)*(A(2)+R(1)*A(1))) RETURN END ************************************************************************ * * * PPPPPPPPP HH HH AA SSSSSSSS EEEEEEEEEE * * PPPPPPPPPP HH HH AAAA SSSSSSSSSS EEEEEEEEEE * * PP PP HH HH AA AA SS SS EE * * PP PP HH HH AA AA SS EE * * PPPPPPPPPP HHHHHHHHHH AA AA SSSSSSSSS EEEEEEEE * * PPPPPPPPP HHHHHHHHHH AA AA SSSSSSSSS EEEEEEEE * * PP HH HH AAAAAAAAAA SS EE * * PP HH HH AAAAAAAAAA SS SS EE * * PP HH HH AA AA SSSSSSSSSS EEEEEEEEEE * * PP HH HH AA AA SSSSSSSS EEEEEEEEEE * * * * DIRECT PHASING OF DIFFRACTION DATA * * A PROGRAM BASED ON MULTAN AND RANTAN WITH FACILITIES * * FOR DEALING WITH PSEUDO-SYMMETRIES * * VERSION 1998 * ************************************************************************ SUBROUTINE PHASE C INCLUDE 'FLIB.FD' COMMON /LOCAL/ SPACE(100) COMMON /USER/ IPATH,MS,LIST,NSREQ,PROB,NSPEC,NGEN,NANY,KARL,KMIN, 1 NINPUT,IMK,ITAN,IPUB,IFOM,ISKIP,WTFOM(3),CUT1,CUT2,ICONV(7500), 2 KMAX,IWMIN,NRAN,ISOL,IOFR,IFAST COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2200000),IOR(230000) COMMON /B2/ IPH2(2200000),LOC(230000) COMMON /BA/ IEE(2430000) COMMON /B3/ KNOWN(60000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 X(5000),Y(5000),Z(5000),NZ(5000),ISPB4(10000) COMMON /SCMK/ SCMK(15000),MKREJ,ISTAGE CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * C PRELIMINARY SECTION DEFINE ALL NECESSARY PROGRAM PARAMETERS C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * c OPEN(UNIT=6,FILE='PHASE.OUT',FORM='FORMATTED',STATUS='UNKNOWN') DTOR = ATAN(1.0) / 45.0 RTOD = 1.0 / DTOR C SET UP SIN/COS TABLE DO 100 I=1,450 STABLE(I)=SIN(DTOR*FLOAT(I-1)) 100 CONTINUE STABLE(181)=0.0 STABLE(361)=0.0 LIM(1) = 0 C PROGRAM DIMENSION PARAMETERS - SEE WRITE UP FOR EQUIVALENCES C KUSER1 = NUMBER OF SIGMA2 + PSI ZERO RELATIONSHIPS KUSER1 = 2400000 C KUSER2 = DIMENSION OF IOR, LOC STORE HEMISPHERE OF REFLEXIONS KUSER2 = 230000 C KUSER3 = MAXIMUM NUMBER OF INPUT REFLEXIONS C DIMENSION OF MKG, MKANG, PALF, IZ, IH, E, IPHAZ, WT, ALPHA, IORDE C TWICE DIMENSION OF KDSTOR, WTSTOR, X, Y ,Z, NZ KUSER3 = 15000 C KUSER4 = DIMENSION OF EEE,IEE AND IPH1 IPH2 IN SORT2 C KUSER4 = 2430000 KUSER4 = KUSER1 + 2*KUSER3 C KUSER5 = MAX. NUMBER OF STRONG + PSI ZERO REFLEXIONS KUSER5 = 17000 C DIMENSION OF LIM = KUSER5 + 1 C KUSER6 = DIMENSION OF KNOWN C * * * * * KUSER6 .GE. NUMB * NSYM * NGP * * * * * KUSER6 = 60000 C READ PARAMETERS FROM CONTROL FILE GENERATED BY PREPAR PROGRAM rewind (34) c CALL CCPDPN(10,'PHASKW.TM','UNKNOWN','F',80,0) c OPEN(UNIT=10,FILE='PHASKW.TM',FORM='FORMATTED',STATUS='UNKNOWN') READ (34,200) PROB,CUT1,CUT2,WTFOM 200 FORMAT(/6F10.4) READ (34,220) KMIN,IPATH,ISTAGE,LIST,NSREQ,NANY,NGEN,NSPEC, 1 IFAST,IFOM,ITAN,ISKIP,IMK,IPUB,ISTO,IOFR,MKREJ, 2 NDET,KMAX,NRAN,IWMIN,NINPUT 220 FORMAT(/17I4,//5I5) IF(NINPUT.GT.0) READ (34,250) (ICONV(I),I=1,NINPUT) 250 FORMAT(6I12) CLOSE (34) IF (ISTO.NE.1) GOTO 300 STOP' --- PHASE BYPASSED ---' 300 rewind (2) c CALL CCPDPN(2,'FCOEF.TM','UNKNOWN','U',80,0) CALL CCPDPN(3,'SAPISG2','SCRATCH','U',80,0) c 300 OPEN(UNIT=2,FILE='FCOEF.TM',FORM='UNFORMATTED',STATUS='UNKNOWN') c OPEN(UNIT=3,FILE='SAPI98.SG2',FORM='UNFORMATTED',STATUS='UNKNOWN') PARA(1) = 0.0 IF (IPATH.EQ.2) GO TO 1070 CALL RELATN IF (IPATH.EQ.1) GO TO 1090 1070 CALL RANTAN CLOSE (1) c CLOSE (2) close (3) c CLOSE (3) 1090 end c CLOSE (6) c STOP' --- PHASE COMPLETED ---' c END C----------------------------------------------------------------------- SUBROUTINE UNPACK(INDEX,IH,IK,IL) IH = INDEX / 262144 IS = INDEX - 262144 * IH IK = IS / 512 - 256 IL = IS - 512 * (IK + 256) - 256 RETURN END C----------------------------------------------------------------------- C MARK TAPE TO HALT EXFFT SUBROUTINE ERROR COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) REWIND 2 NIX = -1 WRITE (2) NIX STOP' --- ERROR in PHASE ---' END ************************************************************************ * * * RRRRRR EEEEEEE L A TTTTTTT N N * * R R E L A A T NN N * * R R E L A A T N N N * * RRRRRR EEEEEE L A A T N N N * * R R E L AAAAAAA T N N N * * R R E L A A T N NN * * R R EEEEEEE LLLLLLL A A T N N * * * * PROGRAM FROM MULTAN-80 * * FOR HANDLING PHASE RELATIONSHIPS * * * ************************************************************************ SUBROUTINE RELATN COMMON /LOCAL/ JN(8), JZ(8) COMMON /USER/ IPATH,MS,LIST,NSREQ,PROB,NSPEC,NGEN,NANY,KARL,KMIN, 1 NINPUT,IMK,ITAN,IPUB,IFOM,ISKIP,WTFOM(3),CUT1,CUT2,ICONV(7500), 2 KMAX,IWMIN,NRAN,ISOL,IOFR,IFAST COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2200000),IOR(230000) COMMON /B2/ IPH2(2200000),LOC(230000) COMMON /BA/ IEE(2430000) COMMON /B3/ KNOWN(60000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 X(5000),Y(5000),Z(5000),NZ(5000),ISPB4(10000) COMMON /SCMK/ SCMK(15000),MKREJ,ISTAGE DIMENSION NAG(10) CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * WRITE (6,500) 500 FORMAT(1X,13HPHASE PART 1,9X,27HSET UP SIGMA2 RELATIONSHIPS, 1 8X,'VERSION 1998') C INPUT CELL, GROUP AND SYMMETRY INFORMATION FROM PREPAR rewind (1) c CALL CCPDPN(1,'PHASDT.TM','UNKNOWN','F',80,0) c OPEN(UNIT=1,FILE='PHASDT.TM',FORM='FORMATTED',STATUS='UNKNOWN') CALL INPUT0(NAG) C INPUT REFLEXION DATA AND GENERATE SYMMETRY RELATED REFLEXIONS CALL INPUT1(NIOR,LIST) IF (NSREQ.EQ.0) THEN NSREQ = 50 IF(KARL.EQ.0) NSREQ=1000 END IF c IF (NUMB.LE.1000) GOTO 700 c IF (NRAn.EQ.250.OR.NRAn.EQ.100.OR.NRAn.EQ.500) NRAN=NDET/2 700 IF (ISOL.EQ.1) NDET=NUMB IF (NUMB * NGP * NSYM .LE. KUSER6) GO TO 820 WRITE (6,810) NUMB,NGP,NSYM,KUSER6 810 FORMAT(/1X,33HNUMB*NGP*NSYM .GT. KUSER6, NUMB =,I4,2X, 1 5HNGP =,I4,2X,6HNSYM =,I4,2X,8HKUSER6 =,I5) CALL ERROR C GROUP TRANSFORM 820 IF (NGP.GT.0) CALL FORM(NAG) C SORT PACKED INDICES KEEPING TRACK OF ADDRESS IN LOC CALL SORT1(IOR,LOC,NIOR) C SET UP SIGMA2 RELATIONSHIPS CALL SIGMA2(NIOR,1,NSRTOT) IF (ISTAGE.EQ.2.AND.MKREJ.EQ.1) WRITE (6,880) 880 FORMAT(//1X,35HPHASE RELATIONSHIPS INVOLVING THREE, 1 34H "SYSTEMATICALLY WEAK REFLECTIONS"/29X,' HAVE BEEN REJECTED') WRITE (6,900) NSRTOT 900 FORMAT(/14X,42HTHE TOTAL NUMBER OF PHASE RELATIONSHIPS IS,I9) SIGMA=0.005*SIGMA SIGMAQ=-FLOAT(ICENT) ICENT=MAX0(ICENT,0) C STORE IOR,LOC FOR PSIZERO RELATIONSHIPS LATER IF (KARL.EQ.0) WRITE (2) IOR,LOC DO 1000 I=1,4 NANT(I) = 0 1000 CONTINUE C READ BACK STRONG RELATIONSHIPS AND SORT THEM CALL SORT2(NSRTOT) E3MAX=0.01*KMAX WRITE (6,1050) NSRTOT,E3MIN,E3MAX 1050 FORMAT(1H ,13X,42HTHE NUMBER OF PHASE RELATIONSHIPS SAVED IS, 1 I9/20X,29HTHE MINIMUM VALUE OF KAPPA IS,F9.2 2 /20X,29HTHE MAXIMUM VALUE OF KAPPA IS,F9.2) C DETERMINE STRUCTURE SEMINVARIANTS FOR ORIGIN DEFINITION AND SIGMA1 C DETERMINE ALSO ALL PHASE RESTRICTIONS CALL GROUP IF (IOFR.NE.0) NORI=0 C SKIP CONVERGENCE IF KARLE RECYCLING IF (KARL.EQ.1) GO TO 1800 C SET CONVERGE PARAMETERS IF (ICENT .EQ. 1) NANY = NANY + NGEN IF (ICENT .EQ. 1) NGEN = 0 IF (LIST.GE.0) WRITE (6,1070) ITLE 1070 FORMAT(//1X,80A1) IF (NSPEC+NGEN+NANY.NE.0) WRITE (6,1080) NSPEC,NGEN,NANY 1080 FORMAT(//1X,41HREFLEXIONS REQUESTED FOR STARTING SET ARE, 1 1X,7HNSPEC =,I3,2X,6HNGEN =,I3,2X,6HNANY =,I3) C IS ENANTIOMORPH DEFINED BY THE INVARIANTS IF (SIGMAQ .GE. 0.25) ICENT = -1 C APPLY SIGMA1 FORMULA CALL SIGMA1(PROB) C INPUT USER CHOSEN REFLEXIONS TO THE CONVERGENCE PROCEDURE NORIN = 0 IF (NINPUT.GT.0) CALL INPUT2(NORIN) C NANY = -1 DEFINES DEFAULT PARAMETERS IF (NINPUT + NSPEC + NGEN + NANY .EQ. 0) NANY = -1 IF (NSREQ .GT. 0) WRITE (6,1090) NSREQ 1090 FORMAT(/1X,20X,33HMAXIMUM NUMBER OF SETS REQUIRED =,I5) IF (NSREQ.EQ.0) WRITE (6,1095) 1095 FORMAT(/1X,15X,47HMAXIMUM NUMBER OF SETS IS DETERMINED BY PROGRAM) C CONVERGENCE METHOD FOR ORIGIN AND STARTING POINT DETERMINATION CALL CONVEG(NORIN) IF (ISTAGE.EQ.2.AND.NRAN.EQ.250) NRAN=NUMB-50 C OUTPUT CONVERGENCE RESULTS AND STORE SIGMA2S NSRTOT=LIM(NUMB+1) CALL OUTPT1(NSRTOT,LIST,nsreq) C READ BACK IOR,LOC AND SET UP PSI-ZEROS SIGMA=200.0*SIGMA READ (2) IOR,LOC CALL SIGMA2(NIOR,2,NSRPSI) IF (NSRPSI.GT.0) WRITE (6,1700) IZRO,NSRPSI 1700 FORMAT (//24X,29(1H-)//24X,29HSET UP PSI ZERO RELATIONSHIPS 1 //9X,4HTHE ,I4,32H WEAKEST REFLEXIONS TAKE PART IN,I8, 2 14H RELATIONSHIPS) IF (NSRPSI.GT.0) CALL SORT2(NSRPSI) C SET UP RELATIONSHIP ARRAYS AND WRITE TAPE SIGMA=0.005*SIGMA 1800 CALL OUTPT2(NSRTOT,NSRPSI) RETURN END C----------------------------------------------------------------------- C READ CELL, GROUP AND SYMMETRY INFORMATION FROM PREPAR SUBROUTINE INPUT0(NAG) DIMENSION NAG(10) COMMON /LOCAL/ JN(8), JZ(8) COMMON /USER/ IPATH,MS,LIST,NSREQ,PROB,NSPEC,NGEN,NANY,KARL,KMIN, 1 NINPUT,IMK,ITAN,IPUB,IFOM,ISKIP,WTFOM(3),CUT1,CUT2,ICONV(7500), 2 KMAX,IWMIN,NRAN,ISOL,IOFR,IFAST COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2200000),IOR(230000) COMMON /B2/ IPH2(2200000),LOC(230000) COMMON /BA/ IEE(2430000) COMMON /B3/ KNOWN(60000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 X(5000),Y(5000),Z(5000),NZ(5000) CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * C INPUT INFORMATION FROM CHANNEL 1 KARL=0 ISOL=0 READ (1,420) ITLE,PARA,JN,JZ,ICENT,LATT,NSYM,NGP,NAT 420 FORMAT(80A1/6F10.5/16I5/5I5) READ (1,430) ((TS(I,J),(IS(K,I,J),K=1,3),I=1,3),J=1,NSYM) 430 FORMAT(F11.8,3I3,F11.8,3I3,F11.8,3I3) NN=2 IF (LATT.EQ.1) NN=1 IF (LATT.EQ.6) NN=4 IF (LATT.EQ.7) NN=3 C INPUT GROUPS IF (NGP.EQ.0) GO TO 575 NS=1 NGX=1 DO 570 I=1,NGP READ (1,565) NINF(NGX),NAG(NGX) 565 FORMAT(2I5) C SET FLAG FOR KARLE RECYCLING IF (NINF(NGX).EQ.5) KARL = 1 C SET FLAG FOR SOLVE ENANTIOMORPH IF (NINF(NGX).EQ.8) ISOL=1 NF=NS+NAG(NGX)-1 IF (NINF(NGX).EQ.2.OR.NINF(NGX).GE.5) GO TO 569 IF (ISOL.EQ.1) GO TO 569 READ (1,568) (NZ(K),X(K),Y(K),Z(K),K=NS,NF) 568 FORMAT(I5,3F10.6) NGX=NGX+1 NS=NF+1 GO TO 570 569 READ (1,568) (J,TEMP,TEMP,TEMP,K=NS,NF) 570 CONTINUE NGP=NGX-1 575 SUM1 = 0.0 SUM2 = 0.0 IHVY = 0 DO 580 I=1,8 TEMP=(JN(I)*JZ(I)**2)/NN C SET FLAG IF THE STRUCTURE CONTAINS A HEAVY ATOM IF (JZ(I).GE.10) IHVY = 1 SUM1 = SUM1 + TEMP SUM2 = SUM2 + TEMP * FLOAT(JZ(I)) 580 CONTINUE SIGMA=SUM2/(SUM1**1.5) SUMZ=SUM1 SUMX=SUM1 IF (NGP.EQ.0) GO TO 610 C SUBTRACT GROUP ATOMS FROM RANDOM SUMS NF = 0 DO 600 I=1,NGP NS = NF + 1 NF = NF + NAG(I) DO 590 J=NS,NF NZJ=NZ(J) TEMP=NSYM*(ICENT+1)*JZ(NZJ)*JZ(NZJ) IF (IABS(NINF(I)) .EQ. 3) SUM1=SUM1-TEMP IF (NINF(I) .LT. 0) SUMZ=SUMZ-TEMP SUMX=SUMX-TEMP SUM2=SUM2-TEMP*FLOAT(JZ(NZJ)) NZ(J)=JZ(NZJ) 590 CONTINUE 600 CONTINUE 610 WRITE (6,640) ITLE,SIGMA 640 FORMAT(/80A1//27X,16HSIG3/SIG2**1.5 =,F9.5) IF (NGP.EQ.0) GO TO 750 NF=0 DO 740 I=1,NGP NS=NF+1 NF=NF+NAG(I) IF (NINF(I).EQ.3) WRITE (6,710) 710 FORMAT (//30X,18HCORRECTLY ORIENTED) IF (NINF(I).EQ.4) WRITE (6,720) 720 FORMAT (//29X,20HCORRECTLY POSITIONED) WRITE (6,730) I,NAG(I),(X(J),Y(J),Z(J),NZ(J),J=NS,NF) 730 FORMAT(/12X,19HATOMIC GROUP NUMBER,I5,5X, 1 17HNUMBER OF ATOMS =,I5/1H ,24X,1HX,9X,1HY,9X,1HZ,7X,4HTYPE/ 2 (1H ,24X,3F10.5,I6)) 740 CONTINUE 750 SIGMA = 200.0 * SIGMA RETURN END C----------------------------------------------------------------------- C INPUT REFLEXION DATA AND GENERATE SYMMETRY RELATED REFLEXIONS SUBROUTINE INPUT1(NIOR,LIST) C DIMENSION STATEMENT PARTICULAR TO SUBROUTINE INPUT1 DIMENSION LINE(6,4), ENIL(6) COMMON /LOCAL/ KL1(24), KL2(24), KL3(24), I1(3), I2(3) COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2200000),IOR(230000) COMMON /B2/ IPH2(2200000),LOC(230000) COMMON /BA/ IEE(2430000) COMMON /B3/ KNOWN(60000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 X(5000),Y(5000),Z(5000),NZ(5000) COMMON /SCMK/ SCMK(15000),MKREJ,ISTAGE CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * C EQUIVALENCE STATEMENT PARTICULAR TO SUBROUTINE INPUT1 EQUIVALENCE (KL1(1),LINE(1,1)), (KL2(1),ENIL(1)) DO 52 I=1,3 MAXH(I) = - 999 52 CONTINUE NUMB=0 NIOR=0 C LIMITE = MAXIMUM NUMBER OF REFLEXIONS (LIMITED BY PACKING) LIMITE = MIN0(KUSER3 , 16383) C READ REFLEXION DATA H K L E SCALE C CODE NUMBERS ARE ASSIGNED TO REFLEXIONS IN ORDER OF INPUT 63 READ (1,65) I1,A,B 65 FORMAT(3I5,2F10.3) IF (A .LT. 0.0) GO TO 500 IF (NUMB.LE.LIMITE .AND. NIOR .LE. KUSER2-NSYM) GO TO 100 WRITE (6,70) NUMB 70 FORMAT(//' * ** ***THERE ARE MORE THAN',I4,' I', 1'NPUT REFLEXIONS - PROGRAM TERMINATED*** ** *'//) CALL ERROR C GENERATE SYMMETRY RELATED REFLEXIONS 100 NUMB = NUMB+1 MAXI=1 DO 250 J=1,NSYM KL1(J)=2400 DO 200 I=1,3 KL1(J)=KL1(J)-I1(I)*INT(TS(I,J)*24.0+0.1) 200 CONTINUE KL1(J)=MOD(KL1(J),24) DO 220 I=1,3 I2(I)=IS(I,1,J)*I1(1) + IS(I,2,J)*I1(2) + IS(I,3,J)*I1(3) 220 CONTINUE IND=262144*I2(1)+512*I2(2)+I2(3) KL2(J)=ISIGN(1,IND) KL1(J)=KL1(J)*ISIGN(1,IND) KL3(J)=131328+IABS(IND) DO 230 I=1,3 IF (IABS(I2(I)).GT.MAXH(I)) MAXH(I)=IABS(I2(I)) 230 CONTINUE IF (J.EQ.1) GO TO 250 JM1=J-1 DO 240 I=1,JM1 IF (KL3(I).EQ.KL3(J)) KL3(J)=0 240 CONTINUE IF (KL3(J).GT.KL3(MAXI)) MAXI=J 250 CONTINUE C EXPRESS GENERATED REFLEXIONS IN TERMS OF STANDARD REFLEXION KLS = KL2(MAXI) L = KL1(MAXI) * KLS C STORE STANDARD REFLEXIONS IH(NUMB)=KL3(MAXI) E(NUMB)=A SCMK(NUMB)=B DO 450 J=1,NSYM IF (KL3(J).EQ.0) GO TO 450 KL1(J) = MOD(KL1(J) - KL2(J) * L,24) IF (KL1(J).LT.0) KL1(J)=24+KL1(J) KL2(J)=KL2(J) * KLS IF (KL2(J).EQ.(-1)) KL2(J)=0 C STORE PACKED INDICES IN IOR AND CODE IN LOC NIOR=NIOR+1 IOR(NIOR)=KL3(J) LOC(NIOR)=48*NUMB+2*KL1(J)+KL2(J) 450 CONTINUE GO TO 63 500 IF (LIST.GE.0) WRITE (6,720) NUMB 720 FORMAT (//26X,I5,20H STANDARD REFLEXIONS, 1//1X,3(8H CODE,9H H K L,3X,1HE,2X)) C PRINT STANDARD REFLEXIONS IN ORDER OF SORTED INDICES C SORT REFLEXIONS ON INDICES KEEPING TRACK OF CODE NUMBERS IN LIM DO 730 I=1,NUMB LIM(I) = I 730 CONTINUE CALL SORT1(IH,LIM,NUMB) K = 0 DO 800 J=1,NUMB K = K + 1 I = NUMB + 1 - J LINE(K,1) = LIM(I) CALL UNPACK(IH(I),LINE(K,2),LINE(K,3),LINE(K,4)) IF (I.NE.1.AND.IH(I).EQ.IH(I-1)) WRITE (6,750) (LINE(K,L),L=2,4) 750 FORMAT(/1X,19HWARNING - REFLEXION,3I5,3X, 1 26HOCCURS TWICE IN INPUT DATA/) LIM(I) = -LIM(I) I = -LIM(I) ENIL(K) = E(I) IF (K.LT.3) GO TO 800 IF (LIST.GE.0) WRITE (6,760) ((LINE(L,M),M=1,4),ENIL(L),L=1,3) 760 FORMAT (1X,3(I8,3I3,F6.3)) K = 0 800 CONTINUE IF (K.NE.0.AND.LIST.GE.0) WRITE (6,760) ((LINE(L,M),M=1,4), 1 ENIL(L),L=1,K) C RESORT REFLEXIONS TO INITIAL ORDER CALL SORT1(LIM,IH,NUMB) RETURN END C----------------------------------------------------------------------- C CALCULATE GROUP TRANSFORMS SUBROUTINE FORM(NAG) C DIMENSION STATEMENT PARTICULAR TO SUBROUTINE FORM DIMENSION CTABLE(360),NAG(10) COMMON /LOCAL/ ITS(3,24),I1(3),I2(3),A2(3) COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2200000),IOR(230000) COMMON /B2/ IPH2(2200000),LOC(230000) COMMON /BA/ IEE(2430000) COMMON /B3/ KNOWN(60000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 X(5000),Y(5000),Z(5000),NZ(5000) CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * C EQUIVALENCE STATEMENT PARTICULAR TO SUBROUTINE FORM EQUIVALENCE (STABLE(91),CTABLE(1)) DO 30 I=1,NSYM DO 20 J=1,3 ITS(J,I)=360.0*TS(J,I)+0.5 20 CONTINUE 30 CONTINUE IND=0 NS=1 C LOOP OVER ALL GROUPS DO 1000 IGP=1,NGP NF=NS+NAG(IGP)-1 NGA=IABS(NINF(IGP)) C REFLEXION LOOP DO 900 I=1,NUMB SUMR=0.0 SUMI=0.0 CALL UNPACK(IH(I),I1(1),I1(2),I1(3)) C TRANSFORM FOR EACH SYMMETRY ELEMENT DO 800 ISYM=1,NSYM IARGA=0 DO 110 L=1,3 IARGA=IARGA+I1(L)*ITS(L,ISYM) 110 CONTINUE DO 140 L=1,3 I2(L)=IS(L,1,J)*I1(1) + IS(L,2,J)*I1(2) + IS(L,3,J)*I1(3) 140 CONTINUE DO 170 L=1,3 A2(L)=360.0*FLOAT(I2(L)) 170 CONTINUE IF (NGA.EQ.3) IARGA=0 C LOOP OVER ATOMS IN GROUP DO 200 J=NS,NF ARG=AMOD(A2(1)*X(J)+A2(2)*Y(J)+A2(3)*Z(J)+FLOAT(IARGA),360.0) IF (ARG.LT.(-0.5)) ARG=ARG+360.0 IARG=INT(ARG+1.5) SUMR=SUMR+FLOAT(NZ(J))*CTABLE(IARG) IF (ICENT .EQ. 0) SUMI=SUMI+FLOAT(NZ(J))*STABLE(IARG) 200 CONTINUE IF (NGA.EQ.4) GO TO 800 C STORE STRUCTURE FACTORS FOR SYMMETRY RELATED GROUPS IF (ICENT .EQ. 1) SUMR = 2.0 * SUMR IR=INT(10.0*SQRT(SUMI*SUMI+SUMR*SUMR)+0.5) IF (IR.NE.0) IA=RTOD*ATAN2(SUMI,SUMR)+360.5 IND=IND+1 KNOWN(IND)=360*IR+MOD(IA,360) SUMI=0.0 SUMR=0.0 800 CONTINUE IF (NGA.EQ.3) GO TO 900 C STORE STRUCTURE FACTORS FOR EQUIVALENT REFLEXIONS IF (ICENT .EQ. 1) SUMR = 2.0 * SUMR IA=RTOD*ATAN2(SUMI,SUMR)+360.5 IR=360*INT(10.0*SQRT(SUMI*SUMI+SUMR*SUMR)+0.5) DO 880 ISYM=1,NSYM IARGA=0 DO 850 L=1,3 IARGA=IARGA+I1(L)*ITS(L,ISYM) 850 CONTINUE IX=MOD(IA-IARGA,360)+360 IND=IND+1 KNOWN(IND)=IR+MOD(IX,360) 880 CONTINUE 900 CONTINUE 950 NS=NF+1 1000 CONTINUE RETURN END C----------------------------------------------------------------------- C GENERAL PURPOSE SORT ON TWO INTEGER ARRAYS SUBROUTINE SORT1(IOR,LOC,MOST) DIMENSION IOR(MOST), LOC(MOST) INT = 2 1000 INT = 2*INT IF (INT .LT. MOST) GO TO 1000 INT = MIN0(MOST,(3*INT)/4-1) 1020 INT = INT/2 IFIN = MOST - INT DO 1120 II=1,IFIN I = II J = I + INT IF (IOR(I).GE.IOR(J)) GO TO 1120 L = IOR(J) M = LOC(J) 1060 IOR(J) = IOR(I) LOC(J) = LOC(I) J = I I = I - INT IF (I.LE.0) GO TO 1100 IF (IOR(I).LT.L) GO TO 1060 1100 IOR(J) = L LOC(J) = M 1120 CONTINUE IF (INT .GT. 1) GO TO 1020 RETURN END C----------------------------------------------------------------------- C GENERAL PURPOSE SORT ON THREE INTEGER ARRAYS SUBROUTINE SORT0(IOR,LOC,IST,MOST) DIMENSION IOR(MOST), LOC(MOST), IST(MOST) INT = 2 1000 INT = 2*INT IF (INT .LT. MOST) GO TO 1000 INT = MIN0(MOST,(3*INT)/4-1) 1020 INT = INT/2 IFIN = MOST - INT DO 1120 II=1,IFIN I = II J = I + INT IF (IOR(I).GE.IOR(J)) GO TO 1120 L = IOR(J) M = LOC(J) N = IST(J) 1060 IOR(J) = IOR(I) LOC(J) = LOC(I) IST(J) = IST(I) J = I I = I - INT IF (I.LE.0) GO TO 1100 IF (IOR(I).LT.L) GO TO 1060 1100 IOR(J) = L LOC(J) = M IST(J) = N 1120 CONTINUE IF (INT .GT. 1) GO TO 1020 RETURN END ************************************************************************ * * * SSSSS IIIII GGGGG M M A 22222 * * S S I G G MM MM A A 2 2 * * S I G M M M M A A 2 * * SSSSS I G GGGG M M M A A ==== 2222 * * S I G G M M AAAAAAA 2 * * S S I G G M M A A 2 * * SSSSS IIIII GGGGG M M A A 2222222 * * * * PROGRAM FROM MULTAN-80 FOR SETTING UP PHASE RELATIONSHIPS * * * ************************************************************************ C JUMP=2 : PSI ZERO'S ; JUMP=1 : SIGMA2'S SUBROUTINE SIGMA2(NIOR,JUMP,NSR) C DIMENSION STATEMENT PARTICULAR TO SUBROUTINE SIGMA2 DIMENSION NKEY(15000),IZI1(15000),IZI2(15000) COMMON/LOCAL/I1(3),I2(3),I3(3),I4(3),I5(3) COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2200000),IOR(230000) COMMON /B2/ IPH2(2200000),LOC(230000) COMMON /BA/ IEE(2430000) COMMON /B3/ KNOWN(60000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 X(5000),Y(5000),Z(5000),NZ(5000) COMMON /SCMK/ SCMK(15000),MKREJ,ISTAGE CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * C EQUIVALENCE STATEMENT PARTICULAR TO SUBROUTINE SIGMA2 EQUIVALENCE (NKEY(1),KNOWN(1)) C ARRAY LIM CONTAINS ADDRESS OF H-H' IN ARRAY IOR CALL CCPDPN(7,'SCR7.TM','SCRATCH','U',80,0) REWIND 2 KENAN = 0 IF (ISTAGE.EQ.0) GO TO 470 DO 400 I=1,NUMB IF (SCMK(I).LT.0.0) GO TO 450 400 CONTINUE GO TO 470 450 ISTAGE=2 470 LIMIT=KUSER4-KUSER1 KONST=512*(256-MAXH(2)) KONH=KUSER5/(MAXH(1)+1) KONK=512*(2*MAXH(2)+1)/KONH+1 DO 500 I=1,KUSER5 LIM(I+1) = 0 500 CONTINUE N=KONH*MAXH(1) M=262144*MAXH(1) DO 540 I=1,NIOR 510 IF (IOR(I).GT.M) GO TO 520 M=M-262144 N=N-KONH GO TO 510 520 J=(IOR(I)-M-KONST)/KONK+N LIM(J+1)=I 540 CONTINUE KU5M1=KUSER5-1 DO 570 I=1,KU5M1 J = KUSER5 - I IF (LIM(J).EQ.0) LIM(J) = LIM(J+1) 570 CONTINUE IP = 47 NSRT=0 NSR = 0 I = 1 IF (JUMP .EQ. 2) GO TO 600 NREC=0 580 IF (I .LE. NUMB) GO TO 590 IF (4*KENAN.GT.NSR) ICENT=-1 GO TO 800 C I1 CONTAINS INDICES OF VECTOR H 590 CALL UNPACK(IH(I),I1(1),I1(2),I1(3)) IP = IP+48 EVAL = E(I) GO TO 610 C INPUT REFLEXIONS FOR PSI ZERO 600 IF (NUMB+I.GT.KUSER5) GO TO 603 READ (1,601) I1,EVAL,SCK 601 FORMAT(3I5,2F10.3) IP=100000 IF (EVAL .GE. 0.0) GO TO 605 603 IZRO = I - 1 IF (NSR.EQ.0) IZRO=0 IF (IZRO.NE.0) GO TO 800 RETURN 605 EVAL = 1.0 610 NP=0 DO 740 K=1,NIOR IF (LOC(K).GT.IP) GO TO 740 CALL UNPACK(IOR(K),I2(1),I2(2),I2(3)) J=LOC(K)/48 IF (JUMP.EQ.2.AND.NKEY(J).GT.NDET) GO TO 740 IFAZ2=LOC(K)-48*J ISI2=(2*MOD(IFAZ2,2)-1)*J IFAZ2=IFAZ2/2 DO 730 M=1,3,2 L=M-2 DO 620 N=1,3 I2(N) = - I2(N) 620 CONTINUE C I3 CONTAINS INDICES OF VECTOR H-H' DO 640 N=1,3 I3(N)=I1(N) + I2(N) IF (IABS(I3(N)).GT.MAXH(N)) GO TO 730 640 CONTINUE INDEX=262144*I3(1)+512*I3(2)+I3(3) MARK=-ISIGN(1,INDEX) INDEX=131328+IABS(INDEX) II1=IABS(I3(1)) KUT=(INDEX-262144*II1-KONST)/KONK+II1*KONH+1 LIM1=LIM(KUT+1) LIM2=LIM(KUT) IF (LIM1.GE.LIM2.OR.INDEX.LT.IOR(NIOR)) GO TO 730 C LOOK FOR H-H' IN ARRAY IOR BETWEEN LIMITS LIM1 AND LIM2 N=LIM2-LIM1+1 690 N=(N+1)/2 IR=LIM1+N IF (IOR(IR)-INDEX) 696,700,692 692 LIM1=IR 696 IF (N.LE.1) GO TO 730 GO TO 690 700 K3=LOC(IR)/48 C REJECT 'WWW' RELATIONSHIPS IF (JUMP.EQ.1) SCK=SCMK(I) IF (MKREJ.EQ.0.OR.ISTAGE.LT.2) GO TO 705 IF (AMAX1(SCK,SCMK(J),SCMK(K3)).LT.0.0) GO TO 730 705 IF (JUMP.EQ.2.AND.NKEY(K3).GT.NDET) GO TO 730 IF (I.EQ.J.AND.JUMP.EQ.1) GO TO 710 IF (K3.GE.J) GO TO 730 710 IFAZ3=LOC(IR)-48*K3 ISI3=2*MOD(IFAZ3,2)-1 IFAZ3=IFAZ3/2 C ELIMINATE DUPLICATIONS IND=16384*J+K3 IF (NP.LE.0) GO TO 718 DO 715 IR=1,NP IF (IND.EQ.MKANG(IR)) GO TO 730 715 CONTINUE 718 IF (I .NE. J .OR. JUMP .EQ. 2) GO TO 720 C POSSIBLE SIGMA1 RELATIONSHIP - STORE IN SEPARATE ARRAY NREC = NREC + 1 IF (NREC.GT.KUSER3) GO TO 725 ISI = ISIGN(1,MARK * ISI3) IFAZE = MOD(-L * IFAZ2 * ISI - ISI3*IFAZ3+240, 24) IZI1(NREC)=ISIGN(16384*K3+IFAZE,L*ISI2*ISI) IZI2(NREC)=I*ISI+16384 GO TO 725 720 NSR = NSR + 1 IFAZQ=0 SIGMAQ=SIGMA C CALCULATE SIGMA AND PHASE OF INVARIANT FROM KNOWN STRUCTURE IF (NGP.GT.0.AND.JUMP.EQ.1) CALL SINV(I,J,K3) IF (MOD(IFAZQ,12).NE.0) KENAN=KENAN+1 E3=SIGMAQ*EVAL*E(J)*E(K3) NSRT=NSRT+1 IF (NSRT.LE. LIMIT) GO TO 722 C STORE ON TAPE FOR USE IN SORT2 WRITE (2) (IPH1(II),IPH2(II),IEE(II),II=1,LIMIT) NSRT=1 C PACK RELATIONSHIPS INTO IPH1 IPH2 AND IEE 722 IFAZE=MOD(-IFAZ2*L-MARK*IFAZ3+240+IFAZQ,24) IF (IFAZE .LT. 0) IFAZE = IFAZE + 24 IPH1(NSRT)=32768*(16384-L*ISI2) IPH2(NSRT)=32768*(16384-ISIGN(K3,ISI3)*MARK)+IFAZE IEE(NSRT)=32768*INT(E3+0.5)+(16384-I) 725 NP = NP + 1 MKANG(NP) = IND 730 CONTINUE 740 CONTINUE IF (NREC.GT.KUSER3) NREC=KUSER3 I = I + 1 GO TO (580,600), JUMP 800 WRITE (2) (IPH1(II),IPH2(II),IEE(II),II=1,LIMIT) IF(NREC.EQ.0.OR.JUMP.EQ.2) GOTO 900 WRITE (7) (IZI1(I),IZI2(I),I=1,NREC) 900 RETURN END C----------------------------------------------------------------------- C CALCULATE SIGMA AND PHASE OF INVARIANT FROM KNOWN STRUCTURE SUBROUTINE SINV(I,J,K) COMMON /LOCAL/ I1(3), I2(3),I3(3),I4(3),I5(3) COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2200000),IOR(230000) COMMON /B2/ IPH2(2200000),LOC(230000) COMMON /BA/ IEE(2430000) COMMON /B3/ KNOWN(60000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 X(5000),Y(5000),Z(5000),NZ(5000) CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * CALL UNPACK(IH(J),I4(1),I4(2),I4(3)) CALL UNPACK(IH(K),I5(1),I5(2),I5(3)) C RANDOM PART OF DENOMINATOR SUMS FDI=SUM1 FDJ=SUM1 FDK=SUM1 XDI=SUMX XDJ=SUMX XDK=SUMX C RANDOM PART OF NUMERATOR SUMS FNI=SUMZ FNJ=SUMZ FNK=SUMZ C SET POINTERS FOR EACH REFLEXION IN ARRAY KNOWN INDI=NSYM*(I-1) INDJ=NSYM*(J-1) INDK=NSYM*(K-1) SUMR=SUM2 SUMI=0.0 C LOOP OVER ATOMIC GROUPS DO 1000 IGP=1,NGP N=1 NNG=NINF(IGP) NNA=IABS(NNG) NX=7-2*NNA IF (NNA .EQ. 3) N=NSYM C ONE TABLE LOOK-UP FOR TYPE 4 GROUP, NSYM FOR TYPE 3 GROUP DO 400 ISYM=1,N C FIRST REFLEXION ITEMP = INDI+ISYM KD=KNOWN(ITEMP) ISF=KD/360 T=(0.1*FLOAT(ISF))**2 IF (NNA .EQ. 3) FDI=FDI+T IF (NNG .LT. 0) FNI=FNI+T XDI=XDI+T IAI=KD-360*ISF C SECOND REFLEXION JSY=-KCOMP(I4,I2,ISYM) INC=IABS(JSY) ITEMP=INDJ+INC KD=KNOWN(ITEMP) JSF=KD/360 T=(0.1*FLOAT(JSF))**2 IF (NNA .EQ. 3) FDJ=FDJ+T IF (NNG .LT. 0) FNJ=FNJ+T XDJ=XDJ+T IAJ=KD-360*JSF C THIRD REFLEXION KSY=KCOMP(I5,I3,ISYM) INC=IABS(KSY) ITEMP=INDK+INC KD=KNOWN(ITEMP) KSF=KD/360 T=(0.1*FLOAT(KSF))**2 IF (NNA .EQ. 3) FDK=FDK+T IF (NNG .LT. 0) FNK=FNK+T XDK=XDK+T IAK=KD-360*KSF FACT=0.001*FLOAT(ISF)*FLOAT(JSF)*FLOAT(KSF) IARG=MOD(NX*(ISIGN(1,JSY)*IAJ+ISIGN(1,KSY)*IAK-IAI)+3600,360)+1 C CONTRIBUTIONS TO REAL AND IMAGINARY PARTS FOR ELEMENT ISYM SUMR=SUMR+FACT*STABLE(IARG+90) SUMI=SUMI+FACT*STABLE(IARG) 400 CONTINUE C INCREMENT POINTERS FOR NEXT GROUP INDI=INDI+NSYM*NUMB INDJ=INDJ+NSYM*NUMB INDK=INDK+NSYM*NUMB 1000 CONTINUE SIGMAQ=FNI*FNJ*FNK*(SUMR*SUMR+SUMI*SUMI) SIGMAQ=200.0*SQRT(SIGMAQ/(FDI*FDJ*FDK*XDI*XDJ*XDK)) IFAZQ=INT(AMOD(RTOD*ATAN2(SUMI,SUMR)/15.0+24.5,24.0)) RETURN END C----------------------------------------------------------------------- C FIND THE SYMMETRY ELEMENT RELATING TWO EQUIVALENT REFLEXIONS FUNCTION KCOMP(IB,IA,J) COMMON/SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI DIMENSION IA(3),IB(3),IC(3),ID(3) C GENERATE THE J'TH SYMMETRY RELATED REFLEXION FOR IA DO 130 L=1,3 IC(L)=IS(L,1,J)*IA(1) + IS(L,2,J)*IA(2) + IS(L,3,J)*IA(3) 130 CONTINUE C COMPARE WITH ALL SYMMETRY RELATED REFLEXIONS FOR IB DO 200 I=1,NSYM KCOMP=I DO 180 L=1,3 ID(L)=IS(L,1,I)*IB(1) + IS(L,2,I)*IB(2) + IS(L,3,I)*IB(3) 180 CONTINUE DO 190 L=1,3 IF (ID(L).NE.IC(L)) GO TO 195 190 CONTINUE GO TO 250 195 KCOMP = -KCOMP C COMPARE WITH FRIEDEL OPPOSITE DO 197 L=1,3 IF (ID(L).NE.(-IC(L))) GO TO 200 197 CONTINUE GO TO 250 200 CONTINUE CALL ERROR 250 RETURN END C----------------------------------------------------------------------- C READ BACK RELATIONSHIPS AND SORT FOR CONVERGE SUBROUTINE SORT2(NSR) REAL*4 EEE(2430000) C DIMENSION STATEMENT PARTICULAR TO SUBROUTINE SORT2 DIMENSION IEE(2430000) COMMON /USER/ IPATH,MS,LIST,NSREQ,PROB,NSPEC,NGEN,NANY,KARL,KMIN, 1 NINPUT,IMK,ITAN,IPUB,IFOM,ISKIP,WTFOM(3),CUT1,CUT2,ICONV(7500), 2 KMAX,IWMIN,NRAN,ISOL,IOFR,IFAST COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2430000) COMMON /B2/ IPH2(2430000) COMMON /BA/ EEE COMMON /B3/ KNOWN(60000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * C EQUIVALENCE STATEMENT PARTICULAR TO SUBROUTINE SORT2 EQUIVALENCE (EEE(1),IEE(1)) REWIND 2 DO 50 I=1,KUSER5 LIM(I+1)=0 50 CONTINUE LIMIT=KUSER4-KUSER1 MAX=KUSER1/LIMIT MAX=MAX*LIMIT LF=0 L=0 C READ BACK AND SORT RELATIONSHIPS 100 LS=LF+1 LF=LF+LIMIT L=L+LIMIT IF (L.GT.NSR) LF=LF-L+NSR READ (2) (IPH1(I),IPH2(I),IEE(I),I=LS,LF) IF (L.LT.NSR.AND.LF.LE.MAX-LIMIT) GO TO 100 CALL SORT0(IEE,IPH1,IPH2,LF) IF (NSR.LT.KUSER1) GO TO 120 LF=KUSER1 IF (L.LT.NSR) GO TO 100 NSR=LF C GET MAXIMUM KAPPA 120 NDD=0 DO 131 I=1,NSR IE3=IEE(I)/32768 IF (IE3.LE.KMAX) GO TO 132 NDD=NDD+1 131 CONTINUE 132 KMAX=IE3 IF (NDD.EQ.0) GO TO 138 NDD1 = NDD+1 DO 133 I=NDD1,NSR IEE(I-NDD)=IEE(I) IPH1(I-NDD)=IPH1(I) IPH2(I-NDD)=IPH2(I) 133 CONTINUE 135 NSR=NSR-NDD C GET MINIMUM KAPPA AND SORT RELATIONSHIPS IN FORM C SUITABLE FOR CONVERGE 138 DO 140 I=1,NSR IE3=IEE(I)/32768 IF (IE3.LT.KMIN) GO TO 150 J=IEE(I)-32768*IE3 IEE(I)=32768*J+IE3 140 CONTINUE I = NSR + 1 150 NSR = I - 1 IE3 = IEE(NSR)-32768*(IEE(NSR)/32768) E3MIN = 0.01 * IE3 CALL SORT0(IEE,IPH1,IPH2,NSR) LIM(1)=0 DO 200 I=1,NSR J=IEE(I)/32768 EEE(I)=0.01*FLOAT(IEE(I)-32768*J) J=16384-J LIM(J+1)=I 200 CONTINUE DO 250 I=1,KUSER5 LIM(I+1)=MAX0(LIM(I+1),LIM(I)) 250 CONTINUE C SET KMIN = 0 FOR PSIZROS ON SECOND CALL OF SORT2 KMIN = 0 RETURN END C----------------------------------------------------------------------- C DETERMINE SPACE GROUP TYPE ACCORDING TO THE CATEGORIES OF HAUPTMAN C & KARLE, ACTA CRYST. (1956) 9, 45 AND ACTA CRYST. (1959) 12, 93 C AND KARLE & HAUPTMAN, ACTA CRYST. (1961) 14, 217, GIVEN ONLY THE C GENERAL EQUIVALENT POSITIONS AND LATTICE TYPE - GIVES NECESSARY C INFORMATION ON NUMBER AND TYPE OF REFLEXIONS USED FOR ORIGIN C DEFINITION, SEMINVARIANT MODULUS & REDUCED INDICES FOR REFLEXIONS C ROUTINE WILL HANDLE 230 SPACE GROUPS IN THE STANDARD ORIENTATIONS C INCLUDING ALTERNATIVE SETTINGS AS IN INTERNATIONAL TABLES VOLUME 1 C DETERMINE ALSO THE PHASE RESTRICTIONS FOR ALL REFLEXIONS C TEST WHETHER THE ENANTIOMORPH IS FIXED BY THE SPACE GROUP SUBROUTINE GROUP REAL*4 EEE(2400000) COMMON/LOCAL/ IND(3),KHL(4) COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000),ALPHA(15000),WT(15000) COMMON /B2/ IPH2(2400000),IPHAZ(15000),IORDE(15000) COMMON /BA/ EEE COMMON /B3/ KNOWN(60000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * C INITIALIZE PARAMETERS NRAL = 0 DO 1000 I=1,3 MODUL(I) = 2 1000 CONTINUE C IT = 3 TESTS FOR Z IN 1ST COORD. OF GENERAL EQUIVALENT POSITIONS C - GIVES RHOMBOHEDRAL OR CUBIC C IT = 2 TESTS FOR Y IN 1ST COORD. - GIVES TETRAGONAL, HEXAGONAL OR C TRIGONAL DO 1060 II=1,2 DO 1040 J=1,NSYM IF (IS(4-II,1,J).NE.0) GO TO 1500 1040 CONTINUE 1060 CONTINUE C SPACE GROUP MUST BE TRICLINIC, MONOCLINIC OR ORTHORHOMBIC C THREE REFLEXIONS ARE NORMALLY REQUIRED FOR ORIGIN DEFINITION NORI = 3 IF (ICENT) 1080,1080,1160 C DETERMINE SEMINVARIANT MODULUS VECTOR (MODUL) AND NUMBER OF AXES C ALONG WHICH THE ORIGIN POSITION IS INFINITELY VARIABLE (NRAL) 1080 NRAL = 3 DO 1140 I=1,3 MODUL(I) = 1000 DO 1100 J=1,NSYM IF (IS(I,I,J).LT.0) GO TO 1120 1100 CONTINUE GO TO 1140 1120 MODUL(I) = 2 NRAL = NRAL - 1 1140 CONTINUE C CHECK FOR CENTRED LATTICE 1160 GO TO (1380,1260,1180,1220,1380,1320,1380), LATT C B CENTRED LATTICE - TEST FOR B2 OR BM, BB 1180 IF (NRAL.LE.1) GO TO 1380 1200 II= 2 MODUL(3) = 1000 GO TO 1280 C C CENTRED LATTICE - TEST FOR C2 OR CM, CC 1220 IF (NRAL.LE.1) GO TO 1380 1240 MODUL(2) = 1000 1260 II = 3 C A CENTRED LATTICES, BM, BB, CM, CC C DETERMINE REDUCED INDICES FOR ALL REFLEXIONS 1280 DO 1300 I=1,NUMB CALL UNPACK(IH(I),IND(1),IND(2),IND(3)) MKG(I)=512*(MOD(IND(1),MODUL(2))+256)+MOD(IND(II),MODUL(3))+256 1300 CONTINUE GO TO 2000 C F CENTRED LATTICE - TEST POINT GROUP SYMMETRY AROUND (1/4,1/4,1/4) C TO DETECT F222 IF SPACE GROUP IS NON-CENTROSYMMETRIC 1320 IF (ICENT.GT.0) GO TO 1980 CALL TEST(1,1,1,4,MM) IF (MM.EQ.0) GO TO 1960 C TRICLINIC, MONOCLINIC & ORTHORHOMBIC EXCEPT A CENTRED, BM,BB,CM,CC C DETERMINE REDUCED INDICES FOR ALL REFLEXIONS 1380 DO 1400 I=1,NUMB CALL UNPACK(IH(I),IND(1),IND(2),IND(3)) MKG(I)=262144*MOD(IND(1),MODUL(1))+512*(MOD(IND(2),MODUL(2) 1 ) + 256) + MOD(IND(3),MODUL(3)) + 256 1400 CONTINUE GO TO 2000 C SPACE GROUP MUST BE TETRAGONAL, TRIGONAL, HEXAGONAL OR CUBIC 1500 IF (ICENT) 1520,1520,1640 1520 IF (LATT - 1) 1600,1540,1600 C TEST WHETHER ENANTIOMORPH IS FIXED BY THE SPACE GROUP 1540 DO 1560 I=1,NSYM IT = 24.0 * TS(3,I) + 0.1 IF (MOD(IT,12)) 1580,1560,1580 1560 CONTINUE GO TO 1600 C ENANTIOMORPH FIXED BY SPACE GROUP - SET FLAG 1580 ICENT = -1 C IS ORIGIN POSITION INFINITELY VARIABLE ALONG Z C SET FLAG (NRAL) AND 3RD COMPONENT OF SEMINVARIANT MODULUS VECTOR 1600 DO 1620 I=1,NSYM IF (IS(3,3,I)) 1640,1620,1620 1620 CONTINUE C SPACE GROUP MUST BE 2P20, 3P30, 3P(1)0 OR 3P(2)0 NRAL = 1 MODUL(3) = 1000 C BRANCH FOR RHOMBOHEDRAL AND CUBIC 1640 GO TO (1940,1660), II C TEST POINT GROUP SYMMETRY AROUND (1/2,1/2,0) TO DETECT TETRAGONAL 1660 CALL TEST(1,1,0,2,MM) IF (MM) 1820,1680,1820 C SPACE GROUP MUST BE TETRAGONAL C TWO REFLEXIONS ARE NORMALLY REQUIRED FOR ORIGIN DEFINITION 1680 NORI = 2 IF (LATT.NE.5) GO TO 1780 C I CENTRED TETRAGONAL - TEST POINT GROUP SYMMETRY AROUND C (0,1/2,1/4) TO DETECT BAR 4 AXIS CALL TEST(0,2,1,4,MM) IF (MM.NE.0) GO TO 1780 C SPACE GROUP MUST BE 3P(3)4 MODUL(3) = 4 C DETERMINE REDUCED INDICES FOR ALL REFLEXIONS DO 1740 I=1,NUMB CALL UNPACK(IH(I),IND(1),IND(2),IND(3)) MKG(I) = MOD(2 * IND(2) + IND(3), MODUL(3)) + 131328 1740 CONTINUE GO TO 2000 C SPACE GROUP MUST BE 3P(3)0 OR 3P(3)2 C ENTER HERE FOR PRIMITIVE TETRAGONAL C DETERMINE REDUCED INDICES FOR ALL REFLEXIONS 1780 DO 1800 I=1,NUMB CALL UNPACK(IH(I),IND(1),IND(2),IND(3)) MKG(I) = 512*(MOD(IND(1) + IND(2), MODUL(2)) + 256) + MOD(IND(3), 1 MODUL(3)) + 256 1800 CONTINUE GO TO 2000 C SPACE GROUP MUST BE TRIGONAL OR HEXAGONAL 1820 IF (ICENT) 1840,1840,1900 C TEST POINT GROUP SYMMETRY AROUND (1/3,2/3,0) TO DETECT 3P30 & 3P32 1840 IF (LATT - 7) 1850,1900,1900 1850 CALL TEST(1,2,0,3,MM) IF (MM) 1900,1860,1900 C SPACE GROUP MUST BE 3P30 OR 3P32 1860 MODUL(2) = 3 C DETECT 6P6 IF (MODUL(3).EQ.2) GO TO 1890 C TWO REFLEXIONS ARE NORMALLY REQUIRED FOR ORIGIN DEFINITION NORI = 2 C DETERMINE REDUCED INDICES FOR ALL REFLEXIONS DO 1880 I=1,NUMB CALL UNPACK(IH(I),IND(1),IND(2),IND(3)) MKG(I) = 512*(MOD(IND(1) - IND(2), MODUL(2)) + 256) + MOD(IND(3), 1 MODUL(3)) + 256 1880 CONTINUE GO TO 2000 C ONE REFLEXION NORMALLY REQUIRED FOR ORIGIN DEFINITION 1890 NORI=1 MODUL(3)=6 C DETERMINE REDUCED REFLEXIONS FOR ALL REFLEXIONS DO 1895 I=1,NUMB CALL UNPACK(IH(I),IND(1),IND(2),IND(3)) MKG(I)=MOD(2*IND(1)+4*IND(2)+3*IND(3),MODUL(3)) 1895 CONTINUE GO TO 2000 C SPACE GROUP MUST BE 3P(1)0, 3P(1)2 OR RHOMBOHEDRAL USING HEXAGONAL C AXES C ONE REFLEXION IS NORMALLY REQUIRED FOR ORIGIN DEFINITION 1900 NORI = 1 C DETERMINE REDUCED INDICES FOR ALL REFLEXIONS DO 1920 I=1,NUMB CALL UNPACK(IH(I),IND(1),IND(2),IND(3)) MKG(I) = MOD(IND(3),MODUL(3)) + 131328 1920 CONTINUE GO TO 2000 C SPACE GROUP MUST BE 3P(2)0, 3P(2)2, 3P(2)4 OR 4P111 C TEST POINT GROUP SYMMETRY AROUND (1/4,1/4,1/4) TO DETECT 3P(2)4 1940 IF (ICENT) 1950,1950,1980 1950 IF (LATT - 7) 1960,1980,1980 1960 CALL TEST(1,1,1,4,MM) IF (MM) 1980,1970,1980 1970 MODUL(3) = 4 C ONE REFLEXION IS NORMALLY REQUIRED FOR ORIGIN DEFINITION 1980 NORI = 1 C DETERMINE REDUCED INDICES FOR ALL REFLEXIONS DO 1990 I=1,NUMB CALL UNPACK(IH(I),IND(1),IND(2),IND(3)) MKG(I) = MOD(IND(1) + IND(2) + IND(3), MODUL(3)) + 131328 1990 CONTINUE C CALCULATE PHASE RESTRICTIONS ON ALL REFLEXIONS 2000 DO 2040 I=1,NUMB MKANG(I) = 13 ALPHA(I) = 0.0 PALF(I) = 0.0 2040 CONTINUE IF (ICENT .GT . 0) GO TO 2240 DO 2200 I=1,NUMB MKANG(I) = 1 CALL UNPACK(IH(I),IND(1),IND(2),IND(3)) C GENERATE SYMMETRY RELATED REFLEXIONS DO 2180 J=1,NSYM DO 2080 K=1,4 KHL(K) = 0 2080 CONTINUE DO 2140 K=1,3 KHL(4) = KHL(4) + IND(K) * INT(TS(K,J) * 12.0 + 0.1) KHL(K)=IS(K,1,J)*IND(1) + IS(K,2,J)*IND(2) + IS(K,3,J)*IND(3) 2140 CONTINUE C HAS FRIEDEL OPPOSITE BEEN GENERATED DO 2160 K=1,3 IF (IND(K) + KHL(K)) 2180,2160,2180 2160 CONTINUE C YES - PHASE MUST BE RESTRICTED TO PI*KHL(4)/24 OR PI*KHL(4)/24+PI MKANG(I) = MOD(KHL(4), 12) + 1 IF (MKANG(I) .LE. 1) MKANG(I) = MKANG(I) + 12 GO TO 2200 2180 CONTINUE 2200 CONTINUE DO 2220 I=1,3 MODUL(I) = MOD(MODUL(I),1000) 2220 CONTINUE C ADJUST NUMBER OF ORIGIN DEFINING REFLEXIONS FOR CENTRED LATTICES 2240 GO TO (2280,2260,2260,2260,2260,2300,2280), LATT C A, B, C AND I CENTRED LATTICES 2260 NORI = NORI - 1 2280 RETURN C F CENTRED LATTICES 2300 NORI = IABS(NORI - 2) RETURN END C----------------------------------------------------------------------- C TEST TO SEE IF THE POINT (M1/M4,M2/M4,M3/M4) IS A POSSIBLE ORIGIN C POSITION MM .EQ. 0 IF YES MM .NE. 0 IF NO C THIS ROUTINE IS WRITTEN TO TEST NON-CENTROSYMMETRIC SPACE GROUPS C WITH P, I AND F LATTICES ONLY SUBROUTINE TEST(M1,M2,M3,M4,KNT) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI DO 1220 I=1,NSYM KNT = 0 DO 1140 J=1,3 IS(J,J,I) = IS(J,J,I) - 1 MM = IABS(MOD(IS(1,J,I)*M1 + IS(2,J,I)*M2 + IS(3,J,I)*M3, M4)) IS(J,J,I) = IS(J,J,I) + 1 IF (MM) 1140,1140,1100 1100 IF (2 * MM - M4) 1260,1120,1260 1120 KNT = KNT + 1 1140 CONTINUE IF (KNT) 1220,1220,1160 1160 GO TO (1240,1240,1240,1240,1180,1200,1240), LATT 1180 IF (KNT - 3) 1240,1220,1240 1200 IF (KNT - 2) 1240,1220,1240 1220 CONTINUE KNT = 0 1240 RETURN 1260 KNT = 1 RETURN END C----------------------------------------------------------------------- SUBROUTINE SIGMA1(PROB) REAL*4 EEE(2400000) DIMENSION IZI1(15000),IZI2(15000) COMMON /LOCAL/ LINE(3,6), ENIL(3,2) COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000),ALPHA(15000),ZR(15000) COMMON /B2/ IPH2(2400000),IPHAZ(15000),ZI(15000) COMMON /BA/ EEE COMMON /B3/ KNOWN(60000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * NXSIG = 0 DO 1000 I=1,NUMB ZI(I) = 0.0 ZR(I) = 0.0 IPHAZ(I) = 0 IZ(I)=0 1000 CONTINUE IF (NREC .EQ. 0) GO TO 1150 REWIND (7) READ (7) (IZI1(I),IZI2(I),I=1,NREC) DO 1120 J=1,NREC IZJ=IZI1(J) ISAVE = IABS(IZJ) IND1 = ISAVE / 16384 C TEST FOR STRUCTURE INVARIANT WITH RESTRICTED PHASE IF (MKG(IND1).NE.131328.OR.MKANG(IND1).EQ.1) GO TO 1120 NXSIG = 1 C UNPACK SIGMA1 RELATIONSHIP IND2 = IZI2(J) - 16384 IFAZ = (ISAVE - 16384*IND1 ) * 15 IND2A = IABS(IND2) IF (ISIGN(1,IND2) .NE. ISIGN(1,IZJ)) GO TO 1100 IF (MKANG(IND2A) .EQ. 1) GO TO 1120 IFAZ = IFAZ + ISIGN(30 * (MKANG(IND2A) - 1), IND2) C ACCUMULATE REAL AND IMAGINARY PARTS 1100 ZI(IND1) = ZI(IND1) - (E(IND2A)**2 - 1.0) * SIN(DTOR *FLOAT(IFAZ)) ZR(IND1) = ZR(IND1) + (E(IND2A)**2 - 1.0) * COS(DTOR *FLOAT(IFAZ)) C ACCUMULATE NUMBER OF CONTRIBUTORS TO EACH SIGMA1 INDICATION IPHAZ(IND1) = IPHAZ(IND1) + 1 1120 CONTINUE IF (NXSIG .EQ. 1) GO TO 1200 1150 WRITE (6,1160) 1160 FORMAT(/22X,34H* * * NO SIGMA1 REFLEXIONS * * *) CLOSE (7) RETURN 1200 IF (PROB.LT.1.0) WRITE (6,1220) PROB 1220 FORMAT(//22X,31H* * * SIGMA1 RESULTS * * *//15X,'PHASE ', 1'ACCEPTED IF PROBABILITY GREATER THAN',F5.2/ 17X,'AND NUMBER OF ', 2'CONTRBUTORS IS GREATER THAN 3'// 3 2(38H CODE H K L E PHI PROB NC )) K = 0 DO 1320 I=1,NUMB IF (MKANG(I).EQ.1.OR.MKG(I).NE.131328) GO TO 1320 ARG = 15 * MKANG(I) - 14 T2 = 0.5 * SIGMA*E(I)* (ZI(I)*SIN(DTOR*ARG) + ZR(I)*COS(DTOR*ARG)) K = K + 1 LINE(K,1) = I CALL UNPACK(IH(I),LINE(K,2),LINE(K,3),LINE(K,4)) ENIL(K,1) = E(I) LINE(K,5) = 15 * (MKANG(I) - 1) IF (T2 .LT. 0.0) LINE(K,5) = LINE(K,5) + 180 ENIL(K,2) = 0.5 + 0.5 * TANH(ABS(T2)) LINE(K,6) = IPHAZ(I) IF (ENIL(K,2).LT.PROB.OR.IPHAZ(I).LE.3) GO TO 1240 C SIGMA1 PHASE ACCEPTED IZ(I) = 1000 * LINE(K,5) + INT(200.0 * ENIL(K,2) - 100.0) 1240 IF (K .LT. 3) GO TO 1320 IF (PROB.LT.1.0) WRITE (6,1300) ((LINE(L,J),J=1,4),ENIL(L,1), 1 LINE(L,5),ENIL(L,2),LINE(L,6), L=1,3) 1300 FORMAT (2(I6,3I4,F5.2,I4,F6.3,I3,2X)) K = 0 1320 CONTINUE IF (PROB.LT.1.0.AND.K.NE.0) WRITE (6,1300) ((LINE(L,J),J=1,4), 1 ENIL(L,1),LINE(L,5),ENIL(L,2),LINE(L,6), L=1,K) RETURN END C----------------------------------------------------------------------- SUBROUTINE INPUT2(NORIN) REAL*4 EEE(2400000) COMMON /USER/ IPATH,MS,LIST,NSREQ,PROB,NSPEC,NGEN,NANY,KARL,KMIN, 1 NINPUT,IMK,ITAN,IPUB,IFOM,ISKIP,WTFOM(3),CUT1,CUT2,ICONV(7500), 2 KMAX,IWMIN,NRAN,ISOL,IOFR,IFAST COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000),ALPHA(15000),WT(15000) COMMON /B2/ IPH2(2400000),IPHAZ(15000),IORDE(15000) COMMON /BA/ EEE COMMON /B3/ KNOWN(60000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * KNT = 0 WRITE (6,1200) NINPUT 1200 FORMAT(//10X,'NUMBER OF REFLEXIONS SPECIFIED AS INPUT TO ', 1'CONVERGE =',I5//17X,40H CODE H K L PHASE TYPE WEIGHT) DO 1580 I=1,NINPUT J=ICONV(I)/1000000 IFAZ = (ICONV(I)-J*1000000)/1000 IF (IFAZ .EQ. 0) IFAZ = 360 IWATE = MOD(ICONV(I),1000) WATE = 0.01*FLOAT(IWATE) C OUTPUT INDICES AND REFLEXION TYPE CALL UNPACK(IH(J),LH,LK,LL) IF (IWATE.EQ.200) WRITE (6,1342) J,LH,LK,LL 1342 FORMAT(17X,I5,3I4,9X,6HORIGIN) IF (IWATE.LE.100) WRITE (6,1344)J,LH,LK,LL,IFAZ,WATE 1344 FORMAT(17X,I5,3I4,I6,3X,5HKNOWN,F8.2) IF (IWATE.EQ.400) WRITE (6,1346) J,LH,LK,LL 1346 FORMAT(17X,I5,3I4,8X,8HPERMUTED) IF (IWATE.EQ.300) WRITE (6,1348) J,LH,LK,LL 1348 FORMAT(17X,I5,3I4,6X,12HENANTIOMORPH) IF (IWATE.LE.200) GO TO 1440 IF (IWATE.EQ.400) GO TO 1420 C ENANTIOMORPH FIXING REFLEXION NANT(1) = J C ENTER HERE FOR STARTING SET REFLEXION 1420 IZ(J) = -1 KNT = KNT + 1 GO TO 1580 1440 IF (IWATE.NE.200) GO TO 1560 C ORIGIN DEFINING REFLEXION - CHECK FOR STRUCTURE INVARIANT 1460 IF (MKG(J) .NE. 131328) GO TO 1470 C OUTPUT ERROR MESSAGE WRITE (6,1465) J 1465 FORMAT(//' * INPUT ORIGIN DEFINING REFLEX', 1'ION',I5,' IS A STRU.-INVAR. REFLEXION IGNORED *'//) GO TO 1580 C CHECK ON NUMBER OF ORIGIN DEFINING REFLEXIONS INPUT 1470 NORIN = NORIN + 1 IF (NORIN - NORI -1) 1560,1475,1485 C OUTPUT ERROR MESSAGE - TOO MANY ORIGIN DEFINING REFLEXIONS 1475 WRITE (6,1480) NORI 1480 FORMAT(//' TOO MANY ORIGIN DEFINING REFLEXIONS', 1' HAVE BEEN INPUT'/' AND SPACE GROUP REQUIRES',I2,' REFLEXIONS'//) 1485 WRITE (6,1490) J 1490 FORMAT(/1X,39HEXTRA ORIGIN DEFINING REFLEXION IGNORED, 1 10X,6HCODE =,I5) GO TO 1580 1560 IZ(J) = 1000 * IFAZ + IWATE 1580 CONTINUE NINPUT = KNT RETURN END ************************************************************************ * * * CCCCC OOOOO N N V V EEEEEEE RRRRRR * * C C O O NN N V V E R R * * C O O N N N V V E R R * * C O O N N N V V EEEEEE RRRRRR * * C O O N N N V V E R R * * C C O O N NN V V E R R * * CCCCC OOOOO N N V EEEEEEE R R * * * * PROGRAM FROM MULTAN-80 * * CONVERGENCE METHOD FOR ORIGIN AND STARTING POINT DETERMINATION * * * ************************************************************************ SUBROUTINE CONVEG(NORIN) REAL*4 EEE(2400000) C DIMENSION STATEMENT PARTICULAR TO SUBROUTINE CONVEG DIMENSION IEE(2400000),ICH(4),LINE(5,4) COMMON /USER/ IPATH,MS,LIST,NSREQ,PROB,NSPEC,NGEN,NANY,KARL,KMIN, 1 NINPUT,IMK,ITAN,IPUB,IFOM,ISKIP,WTFOM(3),CUT1,CUT2,ICONV(7500), 2 KMAX,IWMIN,NRAN,ISOL,IOFR,IFAST COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000),ALPHA(15000),BUFR(200),IBUFR(4,200) COMMON /B2/ IPH2(2400000),ALFST(15000),IORDE(15000) COMMON /BA/ EEE COMMON /B3/ KNOWN(60000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) COMMON /SCMK/ SCMK(15000),MKREJ,ISTAGE CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * C EQUIVALENCE STATEMENT PARTICULAR TO SUBROUTINE CONVEG EQUIVALENCE (EEE(1),IEE(1)) DATA ISK/1H*/, NOT/1H / C I1/I0 (BESSEL FUNCTION) VEC(U)=U*(U+0.4807)/((U+0.8636)*U+1.3943) C SET DEFAULTS ILIST = -1 NSR = 0 NGR = 0 MARK = -1 IF (NANY .EQ. (-1)) NSPEC = 10 IF (NANY .EQ. (-1)) NGEN = 10 ITT = NSREQ NSREQ = 100 NSMIN=0 IF (NANY.LT.0) NSMIN=MIN0(2*NAT/3,NSREQ/2-1) C ALL ORIGIN FIXING REFLEXIONS MUST APPEAR IN THE BOTTOM 25 PLACES C OF THE CONVERGENCE MAP LKGIN = NORI + NSPEC + NGEN + NANY + 25 IF (NANY .EQ. (-1)) LKGIN = LKGIN-12 C REFLEXIONS IN BOTTOM 1/3 OF CONVERGENCE MAP MAY GO IN STARTING SET LKSTA = NUMB / 3 CALL CALPHA(LARN,NORIN,LIST,LKGIN,NSPEC) NSRTOT=LIM(NUMB+1) C CALCULATE NUMBER OF PHASES TO BE DETERMINED NDET = MIN0(NDET,NUMB) IF (NDET.EQ.0) NDET=NUMB-MIN0(KUSER3-NUMB,50) IF (ISTAGE.EQ.2.AND.NDET.LT.NUMB-48) NDET=NUMB-48 C INITIALISE COUNTER OF SPACE FOR PSIZERO RELATIONSHIPS NREJ=KUSER1-NSRTOT IF (NSPEC+NGEN+NANY.EQ.0) GO TO 1770 C INITIALISE ARRAYS FOR NEXT PASS OF CONVERGE 1200 KNT = NUMB DO 1210 I=1,NUMB IF (IZ(I) .LT. (-10)) IZ(I) = 0 ALPHA(I) = PALF(I) 1210 CONTINUE 1220 DO 1230 I=1,NSRTOT IF (KNT.LT.NUMB.AND.EEE(I).LT.0.0) GO TO 1230 IF (IPH1(I).LT.0) IPH1(I)=-IPH1(I) IF (IPH2(I).LT.0) IPH2(I)=-IPH2(I) IF (EEE(I).LT.0.0) EEE(I)=-EEE(I) 1230 CONTINUE C LOOK FOR SMALLEST ESTIMATED ALPHA 1240 ALFMIN=1.0E10 DO 1270 I=1,NUMB IF (IZ(I).NE.0.OR.ALPHA(I).GE.ALFMIN) GO TO 1270 MIN=I ALFMIN=ALPHA(I) 1270 CONTINUE IF (ALFMIN.GT.0.9E10) GO TO 1560 IZ(MIN)=-100 IF (ALFMIN .LT. 0.3) ALPHA(MIN) = 0.0 C THIS REFLEXION IS ELIMINATED IF (KNT.GT.ILIST) GO TO 1435 IF (KNT.EQ.ILIST) WRITE (6,1400) 1400 FORMAT (/6H CODE,10H H K L,7H ALFEST,16X,12HCONTRIBUTORS/) CALL UNPACK(IH(MIN),IJ,IK,IL) WRITE (6,1405) MIN,IJ,IK,IL,ALFMIN 1405 FORMAT(1H ,I5,I4,2I3,F6.2) 1435 LAST = MIN C RECORD ORDER OF PHASE DETERMINATION IORDE(KNT) = MIN IF (KNT.NE.LKSTA.OR.ILIST.GE.0) GO TO 1445 DO 1440 I=1,NUMB ALFST(I)=ALPHA(I) 1440 CONTINUE C REDUCE STRONG REFS TO MAKE SPACE FOR PSI-ZEROS IF NECESSARY 1445 IF (ILIST.GE.0.AND.KNT.EQ.NDET.AND.NREJ.LT.1000) NDET=NDET-1 C UPDATE ESTIMATED ALPHAS N=0 DO 1500 IL=MIN,NUMB IF (IL.NE.MIN.AND.IZ(IL).LT.(-10)) GO TO 1500 LI=LIM(IL)+1 LS=LIM(IL+1) IF (LI.GT.LS) GO TO 1500 DO 1480 I=LI,LS IF (IPH1(I).LT.0) GO TO 1480 IJ=IPH1(I)/32768-16384 IJA=IABS(IJ) IF (IL.NE.MIN.AND.IJA.LT.MIN) GO TO 1480 IK=IPH2(I)/32768-16384 IKA=IABS(IK) IF (IL.NE.MIN.AND.IJA.NE.MIN.AND.IKA.NE.MIN) GO TO 1480 VVEC=EEE(I)*VEC(EEE(I)) IF (IZ(IL).EQ.0) ALPHA(IL)=ALPHA(IL)-VVEC IF (IZ(IJA).EQ.0) ALPHA(IJA)=ALPHA(IJA)-VVEC IF (IZ(IKA).EQ.0) ALPHA(IKA)=ALPHA(IKA)-VVEC IPH1(I)=-IPH1(I) IPH2(I)=-IPH2(I) IF (KNT.GT.LKSTA) EEE(I)=-EEE(I) IF (ILIST.LT.0.OR.N.GE.100) GO TO 1480 N=N+1 B = ABS(EEE(I)) IB3 = -IPH2(I)-32768*(IK+16384) IF (IL.NE.MIN) GO TO 1450 IB1 = IJ IB2 = IK GO TO 1470 1450 IX=ISIGN(1,IJ) IF (MIN.EQ.IKA) IX=ISIGN(1,IK) IB1 = IL*IX IB2 = -IK*IX IF (MIN.EQ.IKA) IB2 = -IJ*IX IF (IX.EQ.1) IB3 = MOD(24-IB3,24) 1470 IPH1(I)=-32768*(16384+IB1) IPH2(I)=-32768*(16384+IB2)-IB3 IEE(I)=32768*(16384-MIN)+INT(100.0*B+0.5) IF (KNT.GT.ILIST) GO TO 1475 BUFR(N) = B IBUFR(1,N) = IB1 IBUFR(2,N) = IB2 IBUFR(3,N) = IB3 1475 IF (KNT.LE.NDET) GO TO 1480 C MARK REJECTED RELATIONSHIPS IEE(I)=0 NREJ=NREJ+1 1480 CONTINUE 1500 CONTINUE C OUTPUT WARNING IF WEAK LINK OCCURS ABOVE LISTING OF MAP IF (ILIST.GT.0.AND.KNT.GT.ILIST.AND.N.EQ.0) 1 WRITE (6,1510) KNT,MIN 1510 FORMAT (11X,36H**** WARNING - WEAK LINK IN POSITION,I5, 1 15H WITH REFLEXION,I5,5H ****) KNT = KNT - 1 IF (KNT.GE.ILIST) GO TO 1240 IF (N.EQ.0) WRITE (6,1520) 1520 FORMAT(/1X,'**** WARNING - WEAK LINK - PLEASE EXAMINE', 1 ' CONVERGENCE MAP CAREFULLY ****') M=0 1530 IF (M.GE.N) GO TO 1240 MP=M+1 M=MIN0(N,M+3) WRITE (6,1550) ((IBUFR(J,I),J=1,3),BUFR(I),I=MP,M) 1550 FORMAT(8X,3(3X,2I6,I3,F5.2)) GO TO 1530 C THIS PASS OF CONVERGENCE IS NOW FINISHED 1560 KNT=KNT+1 MARK = MARK + 1 C AFTER THE FIRST PASS OF CONVERGENCE, DEFINE THE ORIGIN C AND PICK A GENERAL REFLEXION (IF DEFAULTS) IF (MARK.NE.0) GO TO 1625 C FIND SUITABLE ORIGIN FIXING REFLEXIONS C ASCEND CONVERGENCE MAP UNTIL THE ORIGIN CAN BE DEFINED IF (NORIN.EQ.NORI) GO TO 1610 1570 DO 1580 I=KNT,LKGIN MIN=IORDE(I) IZ(MIN)=0 CALL ORIGIN(JUMP,NORIN,0,LARN,MIN) IF (JUMP.NE.0) GO TO 1580 IF (ALPHA(MIN).GT.0.3.OR.I.EQ.NUMB) GO TO 1610 LAST=IORDE(I+1) C PREFER REFLEXION WITH HIGHEST ESTIMATED ALPHA IF (PALF(LAST).LE.PALF(MIN)) GO TO 1610 C ALWAYS USE A SPECIAL REFLEXION IF POSSIBLE IF (MKANG(MIN).GT.1.AND.MKANG(LAST).EQ.1) GO TO 1610 IZ(LAST)=0 IZ(MIN)=-100 CALL ORIGIN(JUMP,NORIN,0,LARN,LAST) IF (JUMP.EQ.0) GO TO 1610 IZ(LAST)=-100 IZ(MIN)=0 GO TO 1610 1580 CONTINUE IF (NRAL.EQ.NORI.OR.ICENT.EQ.1) GO TO 1590 C ALLOW EXTRA GENERAL REFLEXIONS IN ORIGIN DEFINITION NRAL=NRAL+1 GO TO 1570 C ORIGIN CANNOT BE DEFINED FROM BOTTOM LKGIN REFLEXIONS C ALLOW ALL REFLEXIONS TO BE CONSIDERED 1590 LKGIN=NUMB IF (LIST.GE.0) WRITE (6,1600) 1600 FORMAT( //' * ** CONVERGENCE HAS DIFFICULTY I', 1'N FINDING GOOD ORIGIN DEFINING REFLEXIONS'/12X,' PLEASE LOOK ', 2'CRITICALLY AT THE CONVERGENCE RESULTS ** *'/) GO TO 1570 C ALLOCATE PHASES TO ORIGIN DEFINING REFLEXIONS 1610 CALL ORIGIN(JUMP,NORIN,1,LARN,0) DO 1615 I=1,NUMB IF (IZ(I).EQ.0) IZ(I)=-100 1615 CONTINUE C ENSURE A GENERAL REFLEXION IS IN THE STARTING SET IF POSSIBLE IF (ILIST.GE.0) GO TO 1820 IF (ICENT.NE.0.OR.NANY.GE.0) GO TO 1725 ALFMIN = 1.0E10 IREC = 0 DO 1620 I=KNT,LKSTA MIN = IORDE(I) IF (IZ(MIN).NE.(-100).OR.ALPHA(MIN).GT.ALFMIN) GO TO 1620 IF (MKANG(MIN).NE.1) GO TO 1620 IREC = MIN 1620 CONTINUE IF (IREC.EQ.0) GO TO 1725 IZ(IREC) = -1 NGR = 1 GO TO 1725 C PUT REFLEXIONS THAT WERE UNDEFINED (ZERO ESTIMATED ALPHA) C ON ELIMINATION INTO STARTING SET IF POSSIBLE. IF NOT, C USE REFLEXION WITH LOWEST ESTIMATED ALPHA. 1625 IF (ILIST.GE.0) GO TO 1820 1627 ALFMIN=1.0E10 IREC=0 DO 1680 I=KNT,LKSTA MIN=IORDE(I) IF (IZ(MIN).GE.(-10)) GO TO 1680 IAL=1 C LOOK FOR LOWEST ESTIMATED ALPHA IF (ALPHA(MIN).GT.ALFMIN) GO TO 1680 IF (ALPHA(MIN).GT.0.3) GO TO 1630 IAL=0 LAST=IORDE(I+1) IF (IZ(LAST).GE.(-10)) GO TO 1680 IF (PALF(LAST).LE.PALF(MIN).OR.ALPHA(LAST).LT.0.3) GO TO 1630 ALPHA(MIN)=ALPHA(LAST) MIN=LAST 1630 IF (MKANG(MIN).LE.1) GO TO 1640 IF (NSPEC.LE.0) GO TO 1650 IF (IAL.EQ.0) NSPEC=NSPEC-1 GO TO 1660 1640 IF (NGEN.LE.0) GO TO 1650 IF (IAL.EQ.0) NGEN=NGEN-1 GO TO 1660 1650 IF (NANY.LE.0) GO TO 1680 IF (IAL.EQ.0) NANY=NANY-1 1660 IF (IAL.EQ.0) GO TO 1670 ALFMIN=ALPHA(MIN) IREC=MIN GO TO 1680 1670 IF (MKANG(MIN).EQ.1) NGR=NGR+1 IF (MKANG(MIN).NE.1) NSR=NSR+1 IZ(MIN)=-1 1680 CONTINUE MARK=MARK+1 IF (MARK.EQ.2) GO TO 1627 IF (IREC.LE.0) GO TO 1770 C WORST REFLEXION AT END OF CONVERGENCE GOES INTO STARTING SET IZ(IREC) = -1 IF (MKANG(IREC).LE.1) GO TO 1690 NSR = NSR+1 IF (NSPEC.LE.0) GO TO 1700 NSPEC = NSPEC - 1 GO TO 1720 1690 NGR = NGR+1 IF (NGEN.LE.0) GO TO 1700 NGEN = NGEN - 1 GO TO 1720 1700 NANY = NANY - 1 1720 IF (NANY.LT.0) GO TO 1770 C REPEAT CONVERGENCE FROM LKSTA 1725 DO 1730 I=KNT,LKSTA J=IORDE(I) ALPHA(J)=ALFST(J) IF (IZ(J).LT.(-10)) IZ(J)=0 1730 CONTINUE KNT=LKSTA C ARE ANY MORE REFLEXIONS TO BE CHOSEN IF (NSPEC+NGEN+NANY.GT.0) GO TO 1220 C IS LISTING OF CONVERGENCE MAP REQUIRED 1770 IF (LIST) 1780,1790,1800 C NO LIST 1780 ILIST = 0 GO TO 1200 C PARTIAL LIST 1790 ILIST=MIN0(60,NUMB) IF (ILIST .LT. NUMB) WRITE (6,1795) ILIST 1795 FORMAT(/1X,49HPARTIAL CONVERGENCE LISTING - FINAL STAGES ONLY -, 1 I5,11H REFLEXIONS/) GO TO 1200 C COMPLETE LIST 1800 ILIST = NUMB GO TO 1200 1820 KNT = 0 C FIND RELATIONSHIPS AMONGST THE STARTING SET REFLEXIONS DO 1860 I=1,NUMB IF (IZ(I).LT.(-10)) GO TO 1860 KNT = KNT + 1 IORDE(KNT) = I LI=LIM(I)+1 LS=LIM(I+1) IF (LI.GT.LS) GO TO 1860 DO 1840 J=LI,LS IF (IPH1(J).LE.0) GO TO 1840 IL=IPH1(J)/32768-16384 IF (IPH2(J).LE.0) GO TO 1840 IJ=IPH2(J)/32768-16384 IK=IPH2(J)-32768*(IJ+16384) IPH1(J)=-32768*(16384+IL) IPH2(J)=-32768*(16384+IJ)-IK IEE(J)=32768*(16384-I)+INT(100.0*EEE(J)+0.5) 1840 CONTINUE 1860 CONTINUE C SORT RELATIONSHIPS IN CONVERGENCE MAP ORDER FOR FASTAN CALL SORT0(IEE,IPH1,IPH2,NSRTOT) DO 1880 I=1,KUSER5 LIM(I+1)=0 1880 CONTINUE DO 1900 I=1,NSRTOT IPH1(I)=-IPH1(I) IPH2(I)=-IPH2(I) J=IEE(I)/32768 IF (J.EQ.0) GO TO 1910 EEE(I)=0.01*FLOAT(IEE(I)-32768*J) J=16384-J LIM(J+1)=I 1900 CONTINUE 1910 DO 1950 I=1,KUSER5 LIM(I+1)=MAX0(LIM(I+1),LIM(I)) 1950 CONTINUE C FIX ENANTIOMORPH CALL START NREJ=NUMB-NDET IF (NREJ.EQ.0) GO TO 2500 C OUTPUT REJECTED REFLEXIONS WRITE (6,2000) NREJ 2000 FORMAT(/1X,24HCONVERGENCE HAS REJECTED, 1 I4,44H REFLEXIONS FROM PHASE DETERMINATION PROCESS) IF (LIST.LT.0) GO TO 2250 WRITE (6,2010) 2010 FORMAT(//1X,4(18H CODE H K L MK )) K=0 NDETP1=NDET+1 DO 2200 II=NDETP1,NUMB LL=IORDE(II) K=K+1 LINE(1,K)=LL CALL UNPACK(IH(LL),LINE(2,K),LINE(3,K),LINE(4,K)) LINE(5,K)=MKANG(LL) ICH(K)=NOT IF (MKG(LL).EQ.131328) ICH(K)=ISK IF (K.LT.4) GO TO 2200 WRITE (6,2100)((LINE(I,L),I=1,5),ICH(L),L=1,4) 2100 FORMAT(1X,4(I5,4I3,A1)) K=0 2200 CONTINUE IF (K.NE.0) WRITE (6,2100)((LINE(I,L),I=1,5),ICH(L),L=1,K) 2250 NSRTOT=LIM(NUMB+1) WRITE (6,2300) NSRTOT 2300 FORMAT(1H ,16X,39HTHE NUMBER OF RELATIONSHIPS ACCEPTED IS,I8) 2500 NSREQ = ITT RETURN END C----------------------------------------------------------------------- C SUM ALPHA'S AND CHECK ORIGIN DEFINITION SUBROUTINE CALPHA(LARN,NORIN,LIST,LKGIN,NSPEC) REAL*4 EEE(2400000) COMMON /LOCAL/ ICH(8), LNE(2,8), ENL(8) COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000),ALPHA(15000),WT(15000) COMMON /B2/ IPH2(2400000),IPHAZ(15000),IORDE(15000) COMMON /BA/ EEE COMMON /B3/ KNOWN(60000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * DATA ISK/1H*/, NOT/1H / C I1/I0 (BESSEL FUNCTION) VEC(U)=U*(U+0.4807)/((U+0.8636)*U+1.3943) ALFRAN = 0.0 NUMS = 0 K = 0 IF (LIST.GE.0) WRITE (6,1000) 1000 FORMAT(//26X,26HTABLE OF ESTIMATED ALPHA'S// 1 5(15H CODE ALPHA MK )) DO 1042 I=1,NUMB LI = LIM(I) + 1 LS = LIM(I+1) IF (LI.GT.LS) GO TO 1042 IF (MKANG(I).GT.1) NUMS=NUMS+1 DO 1040 J=LI,LS C COMPUTE QUANTITIES FOR ESTIMATED AND RANDOM ALPHA IL=IPH1(J)/32768-16384 IR=IPH2(J)/32768-16384 IL=IABS(IL) IR=IABS(IR) EX=EEE(J)*VEC(EEE(J)) PALF(I)=PALF(I)+EX PALF(IL)=PALF(IL)+EX PALF(IR)=PALF(IR)+EX EX=EEE(J)*EEE(J) ALPHA(I)=ALPHA(I)+EX ALPHA(IL)=ALPHA(IL)+EX ALPHA(IR)=ALPHA(IR)+EX 1040 CONTINUE 1042 CONTINUE DO 1100 I=1,NUMB C COMPUTE TOTAL RANDOM ALPHA ALFRAN = ALFRAN + SQRT(ALPHA(I)) C IS THIS PHASE ALREADY DETERMINED BY SIGMA1 IF (IZ(I).NE.0) LKGIN=LKGIN+1 IF (LIST.LT.0) GO TO 1100 K = K + 1 LNE(1,K)=I LNE(2,K)=MKANG(I) ENL(K)=PALF(I) ICH(K)=NOT IF (MKG(I).EQ.131328) ICH(K)=ISK IF (K.LT.5) GO TO 1100 WRITE (6,1055) (LNE(1,L),ENL(L),LNE(2,L),ICH(L),L=1,5) 1055 FORMAT(5(I5,F6.1,I3,A1)) K = 0 1100 CONTINUE NSPEC = MIN0(NSPEC, NUMS) IF (LIST.GE.0.AND.K.GT.0) WRITE (6,1055) (LNE(1,L),ENL(L), 1 LNE(2,L),ICH(L),L=1,K) C CHECK THAT ORIGIN MAY BE DEFINED AT OUTSET LARN = -NRAL 1200 CALL ORIGIN(JUMP,NORIN,0,LARN,0) IF (JUMP.EQ.0) GO TO 1230 IF (NRAL.GE.NORI) GO TO 1220 NRAL = NRAL + 1 GO TO 1200 1220 IF (NORIN .LE. 0) WRITE (6,1225) IF (NORIN .GT. 0) WRITE (6,1227) CALL ERROR 1225 FORMAT (////15X,' * * * ORIGIN CAN NOT BE PROPERLY DEFINED * * *') 1227 FORMAT (////' ORIGIN FIXING REFLEXIONS CHOSEN BY THE USER WILL '/ 1 'NOT FIX THE ORIGIN') 1230 IF (LIST .GE. 0) WRITE (6,1235) 1235 FORMAT(/25X,28(1H-)//30X,19HCONVERGENCE MAPPING/) RETURN END C----------------------------------------------------------------------- C FIND ANY NORI REFLEXIONS FROM THOSE AVAILABLE TO DEFINE THE ORIGIN C ROUTINE WILL HANDLE 230 SPACE GROUPS IN THE STANDARD ORIENTATIONS C INCLUDING ALTERNATIVE SETTINGS AS IN INTERNATIONAL TABLES VOLUME 1 SUBROUTINE ORIGIN(JUMP,NORIN,IAL,LARN,MIN) REAL*4 EEE(2400000) COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000),ALPHA(15000),WT(15000) COMMON /B2/ IPH2(2400000),IPHAZ(15000),IORDE(15000) COMMON /BA/ EEE COMMON /B3/ KNOWN(60000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * JUMP=0 C ORIGIN IS DEFINED BY SPACE GROUP IF (NORI.EQ.0) RETURN C REFLEXION MIN MUST BE INCLUDED IN ORIGIN MUST=0 IF (MIN.EQ.0) MUST=-1 DO 900 I=1,NUMB C TEST IF REFLEXION MIN IS IN ORIGIN DEFINING SET IF (MUST.EQ.1) GO TO 950 IF (I.EQ.MIN) MUST=1 C ELIMINATED REFLEXION IF (IZ(I).LT.0) GO TO 900 C REFLEXION WITH NO SIGMA-2 CONTRIBUTORS IF (PALF(I).LT.0.2) GO TO 900 C SEMINVARIANT REFLEXION IF (MKG(I).EQ.131328) GO TO 900 NRAL1=0 C COUNT GENERAL REFLEXIONS IF (MKANG(I).EQ.1) NRAL1=1 IF (NRAL1.GT.NRAL) GO TO 900 N1=0 C COUNT USER REFLEXIONS REQUESTED IF (MOD(IZ(I),1000).EQ.200) N1=1 IF (NORIN-N1.GE.3) GO TO 900 CALL UNPACK(MKG(I),J1,K1,L1) IF (NORI.GT.1) GO TO 100 C IS MIN INCLUDED IF (MUST.EQ.0) GO TO 900 C TEST WITH ORIGIN RULES IF ONE REFLEXION IS NEEDED TO DEFINE ORIGIN C MODULUS = (2), (3), (4), (6) OR (0) IF (L1.EQ.1) GO TO 1000 IF (L1.EQ.MODUL(3)-1) GO TO 1000 GO TO 900 100 IPO=I+1 IF (IPO.GT.NUMB) GO TO 900 DO 800 J=IPO,NUMB IF (MUST.EQ.2) GO TO 900 IF (J.EQ.MIN) MUST=2 IF (IZ(J).LT.0) GO TO 800 IF (PALF(J).LT.0.2) GO TO 800 IF (MKG(J).EQ.131328) GO TO 800 NRAL2=NRAL1 IF (MKANG(J).EQ.1) NRAL2=NRAL2+1 IF (NRAL2.GT.NRAL) GO TO 800 N2=N1 IF (MOD(IZ(J),1000).EQ.200) N2=N2+1 IF (NORIN-N2.GE.2) GO TO 800 CALL UNPACK(MKG(J),J2,K2,L2) IF (NORI.GT.2) GO TO 200 IF (MUST.EQ.0) GO TO 800 C TEST WITH ORIGIN RULES IF TWO REFLEXIONS ARE NEEDED MDET=K1*L2-K2*L1 MAXM=MAX0(MODUL(2),MODUL(3)) C MODULUS = (0,0) OR (2,2) IF (IABS(MDET).EQ.1) GO TO 1000 IF (MAXM.EQ.0) GO TO 800 C MODULUS = (0,2), (2,0) OR (3,0) IF (MOD(MDET,MAXM).EQ.0) GO TO 800 C MODULUS = (0,2) IF (MODUL(2).EQ.0.AND.JFAC(K1,K2,-1000).NE.1) GO TO 800 C MODULUS = (2,0) OR (3,0) IF (MODUL(3).EQ.0.AND.JFAC(L1,L2,-1000).NE.1) GO TO 800 GO TO 1000 200 JPO=J+1 IF (JPO.GT.NUMB) GO TO 800 DO 700 K=JPO,NUMB IF (MUST.EQ.3) GO TO 800 IF (K.EQ.MIN) MUST=3 IF (IZ(K).LT.0) GO TO 700 IF (PALF(K).LT.0.2) GO TO 700 IF (MKG(K).EQ.131328) GO TO 700 NRAL3=NRAL2 IF (MKANG(K).EQ.1) NRAL3=NRAL3+1 IF (NRAL3.GT.NRAL) GO TO 700 N3=N2 IF (MOD(IZ(K),1000).EQ.200) N3=N3+1 IF (NORIN-N3.GE.1) GO TO 700 CALL UNPACK(MKG(K),J3,K3,L3) IF (MUST.EQ.0) GO TO 700 C TEST WITH ORIGIN RULES IF THREE REFLEXIONS ARE NEEDED MDET=J1*(K2*L3-K3*L2)-J2*(K1*L3-K3*L1)+J3*(K1*L2-K2*L1) MAXM=MODUL(1)+MODUL(2)+MODUL(3) C MODULUS = (0,0,0) OR (2,2,2) IF (IABS(MDET).EQ.1) GO TO 1000 IF (MAXM.EQ.0) GO TO 700 IF (MAXM.EQ.2) GO TO 600 C MODULUS = (0,2,2), (2,0,2) OR (2,2,0) IF (MOD(MDET,2).EQ.0) GO TO 700 C MODULUS = (0,2,2) IF (MODUL(1).EQ.0.AND.JFAC(J1,J2,J3).NE.1) GO TO 700 C MODULUS = (2,0,2) IF (MODUL(2).EQ.0.AND.JFAC(K1,K2,K3).NE.1) GO TO 700 C MODULUS = (2,2,0) IF (MODUL(3).EQ.0.AND.JFAC(L1,L2,L3).NE.1) GO TO 700 GO TO 1000 600 IF (MODUL(2).NE.2) GO TO 650 C MODULUS = (0,2,0) IF (K1.EQ.1.AND.IABS(J2*L3-J3*L2).EQ.1) GO TO 1000 IF (K2.EQ.1.AND.IABS(J3*L1-J1*L3).EQ.1) GO TO 1000 IF (K3.EQ.1.AND.IABS(J1*L2-J2*L1).EQ.1) GO TO 1000 GO TO 700 C MODULUS = (0,0,2) 650 IF (L1.EQ.1.AND.IABS(J2*K3-J3*K2).EQ.1) GO TO 1000 IF (L2.EQ.1.AND.IABS(J3*K1-J1*K3).EQ.1) GO TO 1000 IF (L3.EQ.1.AND.IABS(J1*K2-J2*K1).EQ.1) GO TO 1000 700 CONTINUE 800 CONTINUE 900 CONTINUE 950 JUMP=-1 RETURN 1000 IF (IAL.EQ.0) RETURN L=0 C COUNT GENERAL REFLEXIONS AND ASSIGN PHASES 1050 IF (MKANG(I).GT.1) GO TO 1100 LARN=LARN+1 C IS THIS A POSSIBLE ENANTIOMORPH DEFINING REFLEXION IF (LARN.LE.0) GO TO 1100 IF (NANT(LARN).GT.0) LARN=LARN+1 NANT(LARN)=I IZ(I)=45200 GO TO 1200 1100 M=MKANG(I)-1 IF (MOD(M,12).EQ.0) M=24 IZ(I)=15000*M+200 1200 L=L+1 IF (L.EQ.NORI) RETURN IF (L.EQ.1) I=J IF (L.EQ.2) I=K GO TO 1050 END C----------------------------------------------------------------------- C TEST FOR COMMON FACTOR (.GT.1) AMONGST K,L,N FUNCTION JFAC(K,L,N) JFAC=1 M=MIN0(K,L,IABS(N)) IF (M.EQ.1) RETURN DO 10 I=2,M IF (MOD(K,I).NE.0) GO TO 10 IF (MOD(L,I).NE.0) GO TO 10 IF (N.GT.0.AND.MOD(N,I).NE.0) GO TO 10 JFAC=I GO TO 20 10 CONTINUE 20 RETURN END C----------------------------------------------------------------------- C DETERMINE THE ENANTIOMORPH FIXING REFLEXION SUBROUTINE START REAL*4 EEE(2400000) COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000),ALPHA(15000),WT(15000) COMMON /B2/ IPH2(2400000),IPHAZ(15000),IORDE(15000) COMMON /BA/ EEE COMMON /B3/ KNOWN(60000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * C HAS ENANTIOMORPH BEEN FIXED NANT(1) .EQ. 0 IF NOT 1580 IF (NANT(1)) 2160,1590,1584 C DOES THE ENANTIOMORPH FIXING REFLEXION ALSO DEFINE THE ORIGIN 1584 MAX = NANT(1) ALFMAX = ABS(PALF(MAX)) IF (IZ(MAX).GE.0) GO TO 2160 C DOES THE ENANTIOMORPH NEED TO BE FIXED - ICENT .NE. 0 IF NOT IF (ICENT) 2105,1595,2105 1590 IF (ICENT.NE.0) GO TO 2160 C ENANTIOMORPH TO BE FIXED - INITIALISE PALF 1595 DO 1597 I=1,NUMB PALF(I) = ABS(PALF(I)) 1597 CONTINUE JUMP = 0 NAN = 1 C TEST FOR PRIMITIVE SPACE GROUP WITH SEMINVARIANT MODULUS (2,2,2) IF (LATT.NE.1) GO TO 1605 J = 4 - NORI DO 1603 I=J,3 IF (MODUL(I).NE.2) GO TO 1605 1603 CONTINUE JUMP = 1 1605 IF (NANT(1).NE.0) GO TO 1625 C SELECT ENANTIOMORPH REFLEXION FROM BOTTOM OF THE CONVERGENCE MAP C IS THERE A PERMUTABLE REFLEXION IN THE STARTING SET? DO 1607 I=1,NUMB IF (IZ(I).EQ.(-1)) GO TO 1608 1607 CONTINUE GO TO 2120 C SELECT LOWEST REFLEXION USED IN CONVERGENCE MAP 1608 MAX = 0 ALFMAX = 0.0 DO 1615 I=1,NUMB MIN = IORDE(I) IF (IZ(MIN).NE.(-100)) GO TO 1615 LI = LIM(MIN)+1 LF = LIM(MIN+1) IF (LI.GT.LF) GO TO 1615 DO 1610 JJ=LI,LF IL=IPH1(JJ)/32768-16384 ILA = IABS(IL) IF (IZ(ILA).NE.(-1)) GO TO 1609 IF (PALF(ILA).LE.ALFMAX) GO TO 1609 ALFMAX = PALF(ILA) MAX = ILA 1609 IR=IPH2(JJ)/32768-16384 IRA = IABS(IR) IF (IZ(IRA).NE.(-1)) GO TO 1610 IF (PALF(IRA).LE.ALFMAX) GO TO 1610 ALFMAX = PALF(IRA) MAX = IRA 1610 CONTINUE IF (MAX.NE.0) GO TO 1625 1615 CONTINUE GO TO 2120 1625 IF (JUMP.LE.0) GO TO 1860 C TO DETERMINE WHETHER ENANTIOMORPH FIXING REFLEXION MUST HAVE C POSITIVE REAL (NAN = -1) OR IMAGINARY (NAN = 1) PART, FIND LINEAR C DEPENDENCE OF ENANTIOMORPH FIXING REFLEXION ON ORIGIN REFLEXIONS 1635 LOG1 = 0 CALL UNPACK(MKG(MAX),M1,M2,M3) CALL UNPACK(MKG(MAX),L1,L2,L3) NORF=0 DO 1800 J=1,NUMB IF (MOD(IZ(J),1000).NE.200) GO TO 1800 NORF=NORF+1 CALL UNPACK(MKG(J),J1,J2,J3) LOG2 = MOD(M1 + J1, 2) + MOD(M2 + J2, 2) + MOD(M3 + J3, 2) IF (LOG2.GT.0) GO TO 1660 C REFLEXION IS LINEARLY DEPENDENT ON ONE ORIGIN REFLEXION IF (IABS(MKANG(J) - 7) - 3) 1840,1820,1820 1660 JP=J+1 IF (NORF.EQ.NORI) JP=1 DO 1670 K=JP,NUMB IF (MOD(IZ(K),1000).EQ.200) GO TO 1675 1670 CONTINUE 1675 CALL UNPACK(MKG(K),K1,K2,K3) LOG2 = MOD(M1+J1+K1,2) + MOD(M2+J2+K2,2) + MOD(M3+J3+K3,2) IF (LOG2.GT.0) GO TO 1700 C REFLEXION IS LINEARLY DEPENDENT ON TWO ORIGIN REFLEXIONS IF (IABS(MOD(MKANG(J) + MKANG(K) - 2, 12) - 6) - 3) 1840,1820,1820 C DETERMINE LINEAR DEPENDENCE ON ALL THREE ORIGIN REFLEXIONS 1700 LOG1 = LOG1 + MKANG(J) - 1 L1 = L1 + J1 L2 = L2 + J2 L3 = L3 + J3 1800 CONTINUE IF (MOD(L1,2) + MOD(L2,2) + MOD(L3,2)) 2100,1810,1820 C REFLEXION IS LINEARLY DEPENDENT ON THREE ORIGIN REFLEXIONS 1810 IF (IABS(MOD(LOG1, 12) - 6) - 3) 1840,1820,1820 C IMAGINARY PART MUST BE POSITIVE TO FIX ENANTIOMORPH 1820 NAN = 1 GO TO 1860 C REAL PART MUST BE POSITIVE TO FIX ENANTIOMORPH 1840 NAN = -1 1860 IF (MKANG(MAX).LE.1) GO TO 2060 IF (IABS(MKANG(MAX) - 7) - 3) 2020,2040,2040 2020 IF (NAN) 2100,2100,2080 2040 IF (NAN) 2080,2100,2100 2060 IF (NAN) 2080,2100,2080 2080 NANT(1) = NAN * MAX GO TO 2160 2100 PALF(MAX) = -PALF(MAX) IF (NANT(1).EQ.0) GO TO 1605 C OUTPUT ERROR MESSAGE 2105 WRITE (6,2110) 2110 FORMAT(//' ENANTIOMORPH FIXING REFLEXION ', 1'CHOSEN BY THE USER DOES NOT FIX ENANTIOMORPH'//) C REMOVE REFLEXION AND TRY AGAIN DO 2115 I=1,3 NANT(I) = NANT(I+1) 2115 CONTINUE GO TO 1580 2120 WRITE (6,2140) 2140 FORMAT( //8X,' THE REFLEXIONS IN THE STARTIN', 1'G SET WILL NOT DEFINE THE ENANTIOMORPH'//) 2160 DO 2180 I=1,NUMB PALF(I) = ABS(PALF(I)) 2180 CONTINUE RETURN END C----------------------------------------------------------------------- C OUTPUT CONVERGENCE RESULTS SUBROUTINE OUTPT1(NSRTOT,LIST,nsreq) REAL*4 EEE(2400000) DIMENSION LINE3(7500,8) COMMON /LOCAL/ LINE1(3,6) COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000) COMMON /B2/ IPH2(2400000),LINE2(3000,5),IORDE(15000) COMMON /BA/ EEE COMMON /B3/ NKEY(15000),MKSTOR(15000),KNOWN(30000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * NS=0 INAN=1 WRITE (6,480) NORI 480 FORMAT(/25X,28(1H-)//29X,20HCONVERGENCE RESULTS 1 //14X,43HTHE NUMBER OF ORIGIN DEFINING REFLEXIONS IS,I6) IF (ICENT .LT. 0 .AND. SIGMAQ .LT. 0.25) WRITE (6,620) 620 FORMAT(/10X,44HTHE ENANTIOMORPH IS FIXED BY THE SPACE GROUP) IF (SIGMAQ .GE. 0.25) WRITE (6,630) 630 FORMAT(/1H ,13X,43HTHE ENANTIOMORPH IS FIXED BY THE INVARIANTS) 700 J = 0 K = 0 L = 0 MARK = 0 C ACCUMULATE NUMBER OF UNKNOWN GENERAL REFLEXIONS IN STARTING SET NRAL = 0 DO 1200 I=1,NUMB IF (IZ(I)+1) 1000,1080,1020 C ELIMINATED REFLEXION 1000 IZ(I) = 0 GO TO 1200 1020 IWT=IZ(I)-1000*(IZ(I)/1000) IF (IWT-100) 1120,1120,1040 C ORIGIN FIXING REFLEXION 1040 J = J + 1 LINE1(J,1) = I CALL UNPACK(IH(I),LINE1(J,2),LINE1(J,3),LINE1(J,4)) LINE1(J,5)=IZ(I)/1000 LINE1(J,6) = MKANG(I) C DOES REFLEXION ALSO FIX ENANTIOMORPH IF (IABS(NANT(1)).EQ.I) NS = NS +1 GO TO 1200 C STARTING SET REFLEXIONS 1080 K = K + 1 LINE2(K,1) = I CALL UNPACK(IH(I),LINE2(K,2),LINE2(K,3),LINE2(K,4)) LINE2(K,5) = MKANG(I) IF (MKANG(I) .NE. 1) IZ(I) = -15000*MOD(MKANG(I)-1, 12) - 360000 IF (MKANG(I) .NE. 1) NS=NS+1 IF (MKANG(I) .EQ. 1) NRAL = NRAL + 1 C NOTE CODE NUMBER OF FIRST SPECIAL REFLEXION IN LIST IF (MARK.NE.0) GO TO 1200 IF (MKANG(I) .NE. 1) MARK = I GO TO 1200 C KNOWN REFLEXION 1120 L = L + 1 LINE3(L,1) = I CALL UNPACK(IH(I),LINE3(L,2),LINE3(L,3),LINE3(L,4)) LINE3(L,5)=IZ(I)/1000 LINE3(L,6)=IWT 1200 CONTINUE C IF NRAL=0, SUBTRACT INCREMENT FROM FIRST UNKNOWN SPECIAL PHASE IF (NRAL .EQ. 0 .AND. MARK .GT. 0) IZ(MARK) = IZ(MARK) + 180000 IF (L .NE. 0) WRITE (6,1240) ((LINE3 (I,M),M=1,6),I=1,L) 1240 FORMAT(//30X,12HKNOWN PHASES//4X,2('CODE H K L PHI ', 1'100*WT',4X)/(4X,2(I4,3I5,2I6,5X))) IF (J.LE.0) GO TO 1400 WRITE (6,1300) ((LINE1(I,M),M=1,6),I=1,J) 1300 FORMAT (/27X,24HORIGIN FIXING REFLEXIONS/ /1X,3('CODE H K', 1' L PHI MK',2X)/1X,3(I4,I3,2I4,I5,I3,2X)) IF (NANT(2).LE.0) GO TO 1400 NN = NANT(2) CALL UNPACK(IH(NN),I1,I2,I3) WRITE (6,1340) I1,I2,I3 1340 FORMAT(/19X,16HTHE PHASE OF THE,3I4,' REFLEXION CAN HAVE'/, 1 23X,'THE TWO VALUES 45 AND 315 DEGREES') NS=NS+1 IF (NANT(3).LE.0) GO TO 1400 NN = NANT(3) CALL UNPACK(IH(NN),I1,I2,I3) WRITE (6,1380) I1,I2,I3 1380 FORMAT(23X,12HAND OF THE,3I4,11H REFLEXION) NS=NS+1 1400 IF (K.NE.0.AND.LIST.GE.0) 1 WRITE (6,1440) ((LINE2(I,M),M=1,5),I=1,K) 1440 FORMAT (//18X,45HOTHER REFLEXIONS IN BOTTOM OF CONVERGENCE MAP 1 //4(2X,16HCODE H K L MK)/4(2X,I4,3I3,I3)) IF (NANT(1).EQ.0) GO TO 1520 NN = IABS(NANT(1)) CALL UNPACK(IH(NN),I1,I2,I3) IF (ICENT.EQ.0) WRITE (6,1500) I1,I2,I3 1500 FORMAT(/12X,32HTHE ENANTIOMORPH IS FIXED BY THE,3I4, 1 11H REFLEXION) IF (ICENT.EQ.0) INAN = 0 1520 NSX = NSREQ NRAL = NSREQ C PRESERVE IORDE IN FORM SUITABLE FOR WEAK RELATIONSHIPS C AND MKANG IN MKSTOR DO 1820 I=1,NUMB MKSTOR(I)=MKANG(I) J=IORDE(I) NKEY(J)=I 1820 CONTINUE C STORE SIGMA2S ON TAPE WHILE SETTING UP PSIZEROS REWIND 3 WRITE (3) (IPH1(I),IPH2(I),EEE(I),I=1,NSRTOT),(LIM(I+1),I=1,NUMB) RETURN END C----------------------------------------------------------------------- C RATIONALISE WEAK REFLEXIONS AND SET UP TAPE FOR TANGENT FORMULA SUBROUTINE OUTPT2(NSRTOT,NSRPSI) REAL*4 EEE(2400000) COMMON /USER/ IPATH,MS,LIST,NSREQ,PROB,NSPEC,NGEN,NANY,KARL,KMIN, 1 NINPUT,IMK,ITAN,IPUB,IFOM,ISKIP,WTFOM(3),CUT1,CUT2,ICONV(7500), 2 KMAX,IWMIN,NRAN,ISOL,IOFR,IFAST COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000),ALPHA(15000),WT(15000) COMMON /B2/ IPH2(2400000),IPHAZ(15000),IORDE(15000) COMMON /BA/ EEE COMMON /B3/ NKEY(15000),MKSTOR(15000),LIMM(15000),ISPZRO(2000), 1 ISP2(4000),ISP3(4000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) COMMON /SCMK/ SCMK(15000),MKREJ,ISTAGE CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * IF (KARL.EQ.1) GO TO 1400 NSRP=NSRPSI C RESTORE MKANG AND IORDE TO THEIR ORIGINAL FORM DO 100 I=1,NUMB MKANG(I)=MKSTOR(I) J=NKEY(I) IORDE(J)=I 100 CONTINUE IF (IZRO.EQ.0) GO TO 1350 C REDUCE WEAK RELATIONSHIPS. NREF AND NREF2 ARE THE C NUMBER OF REFLEXIONS WITH .GE.,.LT. 10 CONTRIBUTORS C IN THE BOTTOM OF THE CONVERGENCE MAP RESPECTIVELY NREF=0 NREF2=0 DO 700 I=1,IZRO LIMM(I)=0 NC1=0 NC2=0 LI=LIM(I)+1 LS=LIM(I+1) IF (LI.GT.LS) GO TO 700 DO 300 JJ=LI,LS IL=IPH1(JJ)/32768-16384 ILA=IABS(IL) IF (NKEY(ILA).GT.100) GO TO 200 IR=IPH2(JJ)/32768-16384 IRA=IABS(IR) IF (NKEY(IRA).GT.100) GO TO 200 NC1=NC1+1 200 NC2=NC2+1 300 CONTINUE IF (NC1.LT.10.OR.NREF.GE.100) GO TO 400 C RECORD WEAK REFS FOR EARLY F.O.M. NREF=NREF+1 ISPZRO(NREF)=I+NUMB LIMM(I)=NC2 C ALLOW THESE REFS TO BE REJECTED LAST NREF2=NREF2+1 ISP2(NREF2)=I ISP3(NREF2)=-1000-NC1 GO TO 700 400 IF (NC2.LT.15.OR.NREF2.GT.200) GO TO 500 C RECORD REFS + CONTRIBS FOR FINAL F.O.M. & REJECTION NREF2=NREF2+1 ISP2(NREF2)=I ISP3(NREF2)=-NC2 LIMM(I)=NC2 GO TO 700 C REMOVE ALL RELATIONSHIPS FOR REJECTED REFLEXION 500 DO 600 JJ=LI,LS EEE(JJ)=0.0 NSRP=NSRP-1 600 CONTINUE 700 CONTINUE IF (NSRP.LE.KUSER1-NSRTOT) GO TO 1000 C REDUCE NO OF WEAK REFS UNTIL RELATIONSHIPS WILL FIT CALL SORT1(ISP3,ISP2,NREF2) DO 900 I=1,NREF2 LL=ISP2(I) LI=LIM(LL)+1 LS=LIM(LL+1) DO 800 JJ=LI,LS EEE(JJ)=0.0 NSRP=NSRP-1 800 CONTINUE LIMM(LL)=0 IF (ISP3(I).GT.(-1000)) GO TO 850 C REDUCE ISPZRO ARRAY IF AN EFOM REFLEXION IS ELIMINATED NREF=NREF-1 KK=LL+NUMB DO 840 J=1,NREF IF (ISPZRO(J).NE.KK) GO TO 840 ISPZRO(J)=ISPZRO(J+1) ISPZRO(J+1)=KK 840 CONTINUE 850 IF (NSRP.LE.KUSER1-NSRTOT) GO TO 1000 900 CONTINUE C MOVE WEAK RELS TO CORRECT PART OF IPH1,IPH2,EEE, & REFS IN LIM C CLOSE UP WEAK RELATIONSHIPS 1000 K = 0 DO 1050 J=1,NSRPSI IF (EEE(J).EQ.0.0) GO TO 1050 K=K+1 EEE(K)=EEE(J) IPH1(K)=IPH1(J) IPH2(K)=IPH2(J) 1050 CONTINUE C MOVE RELATIONSHIPS TO CORRECT PLACES DO 1100 J=1,NSRP K = NSRTOT + J IPH1(K)=IPH1(J) IPH2(K)=IPH2(J) EEE(K)=EEE(J) 1100 CONTINUE C MOVE REFS TO TOP OF LIM & COUNT THE USED REFS K=NSRTOT KNT=0 DO 1200 I=1,IZRO IF (LIMM(I).GT.0) KNT=KNT+1 K=K+LIMM(I) ITEMP = I+NUMB+1 LIM(ITEMP)=K 1200 CONTINUE WRITE (6,1300) KNT,NSRP 1300 FORMAT (1H ,9X,47HPSI ZERO FIGURE OF MERIT TO BE CALCULATED USING 1 ,I5,' REFLEXIONS'/27X,'AND',I8,14H RELATIONSHIPS) C MARK IZRO FOR PSIZERO TEST IF NO RELATIONSHIPS TO BE USED IF (NSRP.EQ.0) IZRO = 0 C READ SIGMA2S BACK & SET UP TAPE FOR TANGENT FORMULA 1350 REWIND 3 READ (3) (IPH1(I),IPH2(I),EEE(I),I=1,NSRTOT),(LIM(I+1),I=1,NUMB) GO TO 1600 C SET UP TAPE FOR KARLE RECYCLING 1400 IZRO = 0 NSRP = 0 NDET = NUMB NREF = 0 NSX = 1 ALFRAN = 0.0 DO 1500 I=1,NUMB IORDE(I)=I IF (I.GT.2000) GO TO 1500 ISPZRO(I)=0 1500 CONTINUE 1600 REWIND 3 WRITE (3) IZRO,NUMB,NSRTOT,NSRP,IPH1,IPH2,EEE,LIM WRITE (3) ICENT,ITLE,LATT,SIGMA,MAXH,PARA,NAT,NDET,IHVY WRITE (3) NSYM,TS,IS WRITE (3) NANT,NREF,ISPZRO,ALFRAN,NRAL,IH,E,MKANG,IZ,IORDE,NSX WRITE (3) ISTAGE,SCMK,ISOL RETURN END ************************************************************************ * * * RRRRRR A N N TTTTTTT A N N * * R R A A NN N T A A NN N * * R R A A N N N T A A N N N * * RRRRRR A A N N N T A A N N N * * R R AAAAAAA N N N T AAAAAAA N N N * * R R A A N NN T A A N NN * * R R A A N N T A A N N * * * * *** AN EXTENSIVE MODIFICATION OF RANTAN-81 *** * * (YAO JIA-XING, ACTA CRYST. A37, 642-644, 1981) * * VERSION 1998 * ************************************************************************ SUBROUTINE RANTAN REAL*4 EEE(2400000) C DIMENSION STATEMENT PARTICULAR TO SUBROUTINE RANTAN DIMENSION KDSTOR(15000),IPSTOR(8500),WTSTOR(8500),NTSTOR(4) COMMON /LOCAL/ AMX(3),AMN(3),LINE(20),LINEX(20) COMMON /USER/ IPATH,MS,LIST,NSREQ,PROB,NSPEC,NGEN,NANY,KARL,KMIN, 1 NINPUT,IMK,ITAN,IPUB,IFOM,ISKIP,WTFOM(3),CUT1,CUT2,ICONV(7500), 2 KMAX,IWMIN,NRAN,ISOL,IOFR,IFAST COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000),ALPHA(15000),WT(15000) COMMON /B2/ IPH2(2400000),IPHAZ(15000),IORDE(15000) COMMON /BA/ EEE COMMON /B3/ EALF(15000),TALF(15000),RALF(15000),ISPZRO(2000), 1 FOM(8000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) COMMON /B6/ IXRAN,IYRAN,PSIMIN,RMIN COMMON /SCMK/ SCMK(15000),MKREJ,ISTAGE COMMON /FOM/ TFOM(3,10),NUD(10),SCUT1,NCUT1,NUMREJ CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * rewind (4) c CALL CCPDPN(4,'KARLE.TM','UNKNOWN','F',80,0) c OPEN(UNIT=4,FILE='KARLE.TM',FORM='FORMATTED',STATUS='UNKNOWN') NUMREJ=0 ISW=0 ITLG=1 IF (IPATH.NE.2) GO TO 1400 1350 REWIND 3 READ (3) IZRO,NUMB,NSRTOT,NSRPSI,IPH1,IPH2,EEE,LIM READ (3) ICENT,ITLE,LATT,SIGMA,MAXH,PARA,NAT,NDET,IHVY READ (3) NSYM,TS,IS READ (3) NANT,NREF,ISPZRO,ALFRAN,NRAL,IH,E,MKANG,IZ,IORDE,NSX READ (3) ISTAGE,SCMK,ISOL 1400 REWIND 3 IF (IFAST.EQ.0) GO TO 1405 ITLG=0 ITAN=0 IFOM=0 NRAN=MIN0(NDET-1,NRAN) IF (NSREQ.EQ.0) NSREQ=MIN0(3*MAX0(10,NAT),100) 1405 PSIMIN=5.0 RMIN=50.0 SCUT1=0.0 NCUT1=0 IF (NSREQ.EQ.0) NSREQ=MAX0(10,NAT) IXRAN = 1 IYRAN = 1 MS=0 IF (ISOL.EQ.1) CALL RESOLV IF (ISOL.EQ.1) GO TO 3000 NSX = NSREQ NSREQ = NSREQ + ISKIP c WRITE (6,1440) HOUR,MINUTE,SECOND,DAY,MONTH,YEAR WRITE (6,1439) ITLE 1439 FORMAT(//1X,13HPHASE PART 2,6X,'TANGENT FORMULA PHASE ', 1 'DETERMINATION VERSION 1998'//80A1/) c 1440 FORMAT(///53X,I2,':',I2,':',I2,3X,I2,'/',I2,'/',I2) WMIN=0.01*IWMIN NNN=MIN0(NDET,NRAN) WRITE (6,1441) NNN 1441 FORMAT (/23X,28HNUMBER OF STARTING PHASES = ,I6) WRITE (6,1442) WMIN 1442 FORMAT (/23X,28HWEIGHT FOR RANDOM PHASES = ,F6.3) IF (ITAN.NE.1) WRITE (6,1444) 1444 FORMAT (/21X,37HCONVENTIONAL WEIGHTED TANGENT FORMULA/) IF (ITAN.EQ.1) WRITE (6,1445) 1445 FORMAT (/21X,38HSTATISTICALLY WEIGHTED TANGENT FORMULA/) REWIND 2 MARK = 0 1470 NCENT = MAX0(ICENT,0) IF (ISTAGE.EQ.2) GO TO 1478 C RESCALE E DO 1475 I=1,NUMB EALF(I)=E(I) 1475 CONTINUE GO TO 1485 C RE-RESCALE E 1478 DO 1480 I=1,NUMB EALF(I)=E(I)/ABS(SCMK(I)) 1480 CONTINUE 1485 WRITE (2) MARK WRITE (2) ITLE, NCENT, LATT, NSYM, 1 ((TS(I,J),(IS(K,I,J),K=1,3),I=1,3),J=1,NSYM), MAXH,PARA,NAT,NUMB, 2 (IH(I),EALF(I),I=1,NUMB) WRITE (6,1500) ISKIP 1500 FORMAT (1H ,21X,30HNUMBER OF PHASE SETS SKIPED IS, I6) MARK = ISKIP IF (IMK.GT.0) GO TO 1800 IF (KARL.NE.1) GO TO 1510 READ (4,1504) IMK 1504 FORMAT(/7X,I4) GO TO 1800 C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C STARTING SETS DETERMINED BY PROGRAM C DO NOT APPLY EARLY FIGURES OF MERIT IN SPECIAL CASES: C 1) IF THE NUMBER OF SETS TO BE DEVELOPED IS LESS THAN 10 C 2) IF NO WEAK REFLEXIONS ARE AVAILABLE C 3) IF THE USER SPECIFIES THE SETS TO BE DEVELOPED C 4) IF THE USER SPECIFIES THE STAT. WEIGHTED TANG. FORMULA C 5) IF THE NUMBER OF PHASES TO BE FOUND IS LESS THAN 100 C 6) IF A HEAVY ATOM EXISTS AND RANTAN IS NOT BEING RUN ALONE 1510 IF (NDET .LT. 100) IFOM = 1 IF (NSX.LT.10.OR.IZRO.EQ.0) IFOM = 1 IF (IPUB.GT.0.OR.ITAN.EQ.1) IFOM = 1 IF (IHVY.EQ.1.AND.IPATH.EQ.0) IFOM = 1 IF (IFOM.GT.0) WRITE (6,1520) 1520 FORMAT(1H ,15X,47HTHE EARLY FIGURE OF MERIT ARE NOT TO BE APPLIED) IF (IFOM.GT.0) GO TO 1580 C CALC. NO OF SETS ACCEPTED BEFORE EFOM ACCEPTANCE REDUCED NSX = 10 C APPLY FIRST EFOM IF SUFFICIENT WEAK REFLEXIONS IF (NRAN.GE.NDET) CUT1=0.0 IF (IZRO.LT.20.AND.CUT1.GT.0.0) WRITE (6,1530) 1530 FORMAT (/10X, 1 60HINSUFFICIENT WEAK REFLEXIONS FOR FIRST EARLY FIGURE OF MERIT) IF (CUT1.EQ.0.0) WRITE (6,1540) 1540 FORMAT(/17X,46HFIRST EARLY FIGURE OF MERIT IS'T TO BE APPLIED) IF (IZRO.LT.20.OR.CUT1.EQ.0.0) IFOM = -1 IF (IFOM.EQ.0) WRITE (6,1550) CUT1 1550 FORMAT (/1X,'FIRST EARLY FIGURE OF MERIT TO BE CALCULATED', 1 ' USING AN INITIAL CUTOFF OF',F6.3) DO 1555 I=1,NSX FOM(I)=CUT1 1555 CONTINUE IF (IFOM.LE.0) WRITE (6,1560) CUT2 1560 FORMAT (/1X,'SECOND EARLY FIGURE OF MERIT TO BE CALCULATED', 1' USING AN INITIAL CUTOFF OF',F6.3) C STORE IZ IN MKG AND NANT IN NTSTOR IN CASE NO SETS DEVELOPED 1580 DO 1590 I=1,NUMB MKG(I)=IZ(I) IF (I.LE.4) NTSTOR(I)=NANT(I) 1590 CONTINUE NSETS = MARK AMN(2) = 100.0 AMN(3) = 100.0 ISETX = 0 ICAP = 0 J = 0 NUMSET = 0 C READ SPECIFIED SET NUMBERS IF (IPUB.GT.0) READ (4,1830) (IPSTOR(I),I=1,IPUB) 1600 NSETS = NSETS + 1 IF (IPUB.GT.0.AND.NSETS.GT.IPUB) GO TO 2040 IF (IPUB.GT.0) ISETX = IPSTOR(NSETS) C CHANGE ROUTINE ACCORDING FIGURES OF MERIT. IF (ISW.NE.0.OR.ITAN.NE.0.OR.ISTAGE.EQ.2) GO TO 1620 IF (NUMSET-ISKIP.NE.10) GO TO 1620 CALL MFOM(ISW) IF (ISW.EQ.0) GO TO 1620 IF (LIST.EQ.-1) WRITE (6,1605) 1605 FORMAT(//1H ,27X,16HFIGURES OF MERIT,3X,12HUNDETERMINED, 1 /20X,3HSET,4X,3HABS,3X,7HPSIZERO,2X,5HRESID,3X,6HPHASES) IF (LIST.EQ.-1) 1 WRITE (6,1610) (J+ISKIP,(TFOM(I,J),I=1,3),NUD(J),J=1,10) 1610 FORMAT(1H ,19X,I3,F8.4,F7.3,F9.2,I7) WRITE (6,1615) 1615 FORMAT(/1X,'THE WEIGHT SCHEME FOR TANGENT REFINEMENT WILL', 1' BE CHANGED TO SWTR AS FOLLOWS') NSREQ = NSREQ - ISKIP GO TO 1350 1620 NUMSET = NUMSET + 1 C PERMUTE STARTING PHASES CALL ASIGN(MARK,ISKIP,ISETX,XP,DX,ITLG) IF (MARK.EQ.0) GO TO 2040 IF (NUMSET.LE.ISKIP.OR.NUMSET.LT.ISETX) GO TO 1620 C TANGENT FORMULA PHASE DETERMINATION IREJ=0 IF (ITAN.NE.1) CALL FASTAN(IFOM,IREJ) IF (NUMREJ.GE.NSREQ.AND.NSREQ.LT.500) NSREQ=NSREQ+100 IF (ITAN.EQ.1) CALL SWTR(0,IREJ) IF (IREJ.EQ.1) NSETS=NSETS-1 IF (IREJ.NE.(-1)) GO TO 1600 NSETS=NSETS+1 NSREQ=NUMSET WRITE (6,1700) NUMSET 1700 FORMAT (//22X,4HSET ,I3,26H ACCEPTED AS TRUE SOLUTION) GO TO 2040 C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C STARTING PHASES INPUT FROM CARDS 1800 NSETS = MARK READ (4,1830) (KDSTOR(I),I=1,IMK) READ (4,1830) (MKG(I),I=1,IMK) 1830 FORMAT(15I5) READ (4,1840) (WTSTOR(I),I=1,IMK) 1840 FORMAT(15F5.2) DO 1890 I=1,IMK IF (MKG(I).LT.0) WTSTOR(I)=-WTSTOR(I) 1890 CONTINUE 1900 READ (4,1830) (MKG(I),I=1,IMK),NUMSET NSETS=NSETS+1 C STARTING PHASES INPUT BY USER SHOULD BE TERMINATED WITH NUMSET = 0 C STARTING PHASES INPUT BY STRUCTURE FACTOR CALCULATION PROGRAM FOR C KARLE RECYCLING THROUGH SWTR ARE TERMINATED WITH NUMSET = -1 IF (NUMSET .EQ. 0) GO TO 2040 DO 1910 I=1,NUMB ALPHA(I) = 0.0 WT(I) = 0.0 IPHAZ(I) = 0 1910 CONTINUE IF (NUMSET.LT.500) GO TO 1980 C COMBINE KARLE-RECYCLE AND RANTAN 1950 NANT(1) = 0 DO 1951 I=1,NUMB IZ(I)=0 MKANG(I)=IABS(MKANG(I)) 1951 CONTINUE DO 1960 I=1,IMK IF (ABS(WTSTOR(I)).LT.0.75) GO TO 1960 IND = KDSTOR(I) DO 1954 J=1,NNN JND = IORDE(J) IF (IND.EQ.JND) GO TO 1955 1954 CONTINUE GO TO 1960 1955 MKANG(IND) = INT(SIGN(1.0,WTSTOR(I)))*MKANG(IND) MKG(I)=MOD(MKG(I)+360,360) IF (MKG(I) .EQ. 0) MKG(I) = 360 IZ(IND) = MKG(I)*1000+INT((2.0*ABS(WTSTOR(I))-1.0)*100.0) 1960 CONTINUE GO TO 1510 1980 IFOM=1 DO 2000 I=1,IMK IND = KDSTOR(I) WT(IND) = ABS(WTSTOR(I)) IF (NUMSET.NE.(-1).AND.WT(IND).LE.0.999) WT(IND) = - WT(IND) MKANG(IND) = INT(SIGN(1.0,WTSTOR(I)))*MKANG(IND) IF (MKG(I) .EQ. 0) MKG(I) = 360 IPHAZ(IND) = MKG(I) 2000 CONTINUE IREJ = 0 IF (NUMSET .EQ. (-1)) GO TO 2030 IF (ITAN.NE.1) CALL FASTAN(IFOM,IREJ) IF (ITAN.EQ.1) CALL SWTR(0,IREJ) GO TO 1900 C KARLE RECYCLING 2030 NUMSET = 0 CALL SWTR(1,IREJ) NSETS = 2 C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C PHASE REFINEMENT COMPLETE 2040 NUMSET = NSETS - 1 NUMSET = NUMSET - ISKIP IF (NUMSET.GT.0) GO TO 3000 C SEE IF ALL SETS REJECTED THROUGH UNDETERMINED PHASES WRITE (6,2050) 2050 FORMAT(1X,'ERROR: ALL SETS REJECTED THROUGH UNDETERMINED PHASES') IF (IFOM.EQ.1) CALL ERROR C ALL SETS REJECTED BY EARLY FIGURES OF MERIT: RELAX CONDITIONS IF (IFOM.NE.0) GO TO 2300 C REMOVE FIRST EARLY FIGURE OF MERIT WRITE (6,2100) 2100 FORMAT(10X,'NO SETS DEVELOPED. REEXAMINE SETS WITHOUT FIRST ', 1'EARY FIGURE OF MERIT') IFOM=-1 IXRAN = 1 IYRAN = 1 GO TO 2400 C REMOVE SECOND EARLY FIGURE OF MERIT 2300 WRITE (6,2350) 2350 FORMAT(/1X,8X,48HNO SETS DEVELOPED. REEXAMINE SETS WITHOUT SECOND 1,22H EARLY FIGURE OF MERIT) IFOM = 1 IXRAN = 1 IYRAN = 1 C RESTORE IZ AND NANT 2400 DO 2500 I=1,NUMB IZ(I)=MKG(I) IF (I.LE.4) NANT(I)=NTSTOR(I) 2500 CONTINUE GO TO 1580 C CHECK FOR IDENTICAL PHASE SETS 3000 CALL COMPAR CLOSE (4) RETURN END C----------------------------------------------------------------------- C GENERATE STARTING SETS OF PHASES FROM CONVERGENCE RESULTS SUBROUTINE ASIGN(MARK,ISKIP,ISETX,XP,DX,ITLG) REAL*4 EEE(2400000) COMMON /USER/ IPATH,MS,LIST,NSREQ,PROB,NSPEC,NGEN,NANY,KARL,KMIN, 1 NINPUT,IMK,ITAN,IPUB,IFOM1,IIIII,WTFOM(3),CUT1,CUT2,ICONV(7500), 2 KMAX,IWMIN,NRAN,ISOL,IOFR,IFAST COMMON /LOCAL/ AMX(3), AMN(3), LINE(20), LINEX(20) COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000),ALPHA(15000),WT(15000) COMMON /B2/ IPH2(2400000),IPHAZ(15000),IORDE(15000) COMMON /BA/ EEE COMMON /B3/ KNOWN(60000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) COMMON /B6/ IXRAN,IYRAN,PSIMIN,RMIN CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * NNN=MIN0(NDET,NRAN) NAN = IABS(NANT(1)) 1000 MARK = 0 IF (ITLG.NE.1.OR.NSREQ.GT.0) GO TO 1005 IF (NUMSET.LE.NSREQ) GO TO 1006 IF (PSIMIN.LT.1.6.AND.RMIN.LT.25.0) RETURN NSREQ=3*MAX0(10,NAT) IF (NSREQ.GT.100) NSREQ=100 ITLG=2 GO TO 1006 1005 IF (NUMSET.GT.NSREQ) RETURN C GENERATE NEXT SET OF PHASES FOR STARTING POINT 1006 MARK=1 IF (MS.EQ.1) GO TO 1040 1010 DO 1035 I=1,NUMB IF (MKG(I)) 1020,1020,1030 1020 IF (IABS(MKANG(I)).EQ.1) GO TO 1025 MPH=15*(IABS(MKANG(I))-1) IRA=360*RRAND(IXRAN,IYRAN)+0.5 IF (IRA.GT.180) MPH=MPH+180 IZ(I)=MPH*1000+IWMIN IF (I.EQ.NAN) IZ(I)=MPH*1000+99 GO TO 1035 1025 MPH=360*RRAND(IXRAN,IYRAN)+0.5 IZ(I)=MPH*1000+IWMIN 1026 IF (I.EQ.NAN) IZ(I)=MPH*1000+85 GO TO 1035 1030 IZ(I)=MKG(I) 1035 CONTINUE MS=1 GO TO 1070 1040 J=2+ICENT DO 1045 I=J,4 IF (NANT(I)) 1045,1060,1050 1045 CONTINUE GO TO 1060 1050 DO 1055 K=J,I NANT(K)=-NANT(K) NN=IABS(NANT(K)) IZ(NN)=-(IZ(NN)-200)+360200 1055 CONTINUE GO TO 1070 1060 DO 1065 I=J,4 NANT(I)=IABS(NANT(I)) 1065 CONTINUE MS=0 GO TO 1010 1070 DO 1200 LL=1,NUMB I=IORDE(LL) IF (LL.GT.NNN) GO TO 1081 IWT=IZ(I)-1000*(IZ(I)/1000) ALPHA(I)=0.0025*IWT*IWT IF (IWT-100) 1080,1100,1100 1080 WT(I)=-0.01*FLOAT(IWT) GO TO 1180 1081 WT(I)=0.0 GO TO 1200 1100 WT(I)=1.0 MKANG(I)=-IABS(MKANG(I)) 1180 IPHAZ(I)=MOD(IABS(IZ(I)/1000)+360,360) 1190 IF (IPHAZ(I) .EQ. 0) IPHAZ(I) = 360 1200 CONTINUE IF (NUMSET .LE. ISKIP .OR. NUMSET .LT. ISETX) RETURN 1360 MARK=1 RETURN END C----------------------------------------------------------------------- C A FUNCTION FOR RANDOM NUMBER FUNCTION RRAND (IX,IY) IX = MOD(251*IX,1048576) IY = MOD(179*IY,1048576) RRAND = FLOAT (MOD(IX+IY,1048576))/1048576.0 RETURN END ************************************************************************ * * * FFFFFFF A SSSSS TTTTTTT A N N * * F A A S S T A A NN N * * F A A S T A A N N N * * FFFFFF A A SSSSS T A A N N N * * F AAAAAAA S T AAAAAAA N N N * * F A A S S T A A N NN * * F A A SSSSS T A A N N * * * * PROGRAM BASED ON MULTAN-80 * * VERSION 1998 * ************************************************************************ SUBROUTINE FASTAN(IFOM,IREJ) LOGICAL TEST REAL*4 EEE(2400000) C DIMENSION STATEMENT PARTICULAR TO SUBROUTINE FASTAN DIMENSION CTABLE(360),SUMNUM(15000),SUMDEN(15000) COMMON /USER/ IPATH,MS,LIST,NSREQ,PROB,NSPEC,NGEN,NANY,KARL,KMIN, 1 NINPUT,IMK,ITAN,IPUB,IFOM1,ISKIP,WTFOM(3),CUT1,CUT2,ICONV(7500), 2 KMAX,IWMIN,NRAN,ISOL,IOFR,IFAST COMMON /LOCAL/ AMX(3),AMN(3),LINE(20),LINEX(20) COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000),ALPHA(15000),WT(15000) COMMON /B2/ IPH2(2400000),IPHAZ(15000),IORDE(15000) COMMON /BA/ EEE COMMON /B3/ EALF(15000),TALF(15000),RALF(15000),ISPZRO(2000), 1 FOM(8000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) COMMON /B6/ IXRAN,IYRAN,PSIMIN,RMIN COMMON /SCMK/ SCMK(15000),MKREJ,ISTAGE COMMON /FOM/TFOM(3,10),NUD(10),SCUT1,NCUT1,NUMREJ CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * C EQUIVALENCE STATEMENT PARTICULAR TO SUBROUTINE FASTAN EQUIVALENCE (STABLE(91),CTABLE(1)) C I1/I0 (BESSEL FUNCTION) VEC(U)=U*(U+0.4807)/((U+0.8636)*U+1.3943) NSTAGE=1 NNN=MIN0(NDET,NRAN) NCYCLE=0 WW=0.0 MARK=0 NALF=0 SALF = 0.0 C CLEAR ARRAYS AT START OF DETERMINATION DO 990 I=1,NUMB EALF(I)=0.0 TALF(I)=0.0 PALF(I)=0.0 SUMNUM(I)=0.0 SUMDEN(I)=0.0 990 CONTINUE C START OF NEXT CYCLE 1000 SUMALF=SALF NCYCLE=NCYCLE+1 SALF=0.0 C TEST IS .TRUE. IF EXPECTED ALPHA IS TO BE CALCULATED C I.E. 2 CYCLES BEFORE FIRST EFOM AND FINAL 2 CYCLES TEST=((NCYCLE.EQ.5.OR.NCYCLE.EQ.6).AND.IFOM.LE.0).OR.MARK.GT.0 DO 1500 I=1,NNN LL=IORDE(I) IF (ISTAGE-NSTAGE.GT.0.AND.SCMK(LL).LT.0.0) GO TO 1500 LI=LIM(LL)+1 LS=LIM(LL+1) IF (LI.GT.LS) GO TO 1200 DO 1100 JJ=LI,LS IL=IPH1(JJ)/32768-16384 ILA=IABS(IL) IF (ABS(WT(ILA)).LT.0.1) GO TO 1100 IR=IPH2(JJ)/32768-16384 IRA=IABS(IR) IF (ISTAGE-NSTAGE.LE.0) GO TO 1040 IF (SCMK(ILA).LT.0.0.OR.SCMK(IRA).LT.0.0) GO TO 1100 1040 IF (ABS(WT(IRA)).LT.0.1) GO TO 1100 EE=EEE(JJ)*ABS(WT(ILA)*WT(IRA)) IF (TEST) VECX=EE*VEC(EEE(JJ)) IF (TEST) EALF(LL)=EALF(LL)+VECX IF (TEST) TALF(LL)=TALF(LL)+EE*EE-VECX*VECX IP=15*(IPH2(JJ)-32768*(IPH2(JJ)/32768)) IF (ICENT.EQ.1) GO TO 1050 IFL=ISIGN(IPHAZ(ILA),IL) IFR=ISIGN(IPHAZ(IRA),IR) IARG=MOD(IFL+IFR+IP+1440,360)+1 SUMNUM(LL)=SUMNUM(LL)+EE*STABLE(IARG) SUMDEN(LL)=SUMDEN(LL)+EE*CTABLE(IARG) GO TO 1100 1050 IF (MOD(IPHAZ(ILA)+IPHAZ(IRA)+IP,360).NE.0) EE=-EE SUMNUM(LL)=SUMNUM(LL)+EE 1100 CONTINUE 1200 ID=15*IABS(MKANG(LL))-14 IF (ID.EQ.1.OR.ICENT.EQ.1) GO TO 1300 T2=SUMNUM(LL)*STABLE(ID)+SUMDEN(LL)*CTABLE(ID) SUMNUM(LL)=T2*STABLE(ID) SUMDEN(LL)=T2*CTABLE(ID) 1300 ALFA=SUMNUM(LL)**2+SUMDEN(LL)**2 IF (ALFA.EQ.0.0) GO TO 1500 IF (MKANG(LL).LE.0) GO TO 1320 SALF=SALF+ALFA WATE=1.0 IF (ALFA.LT.25.0) WATE=0.2*SQRT(ALFA) IF (WT(LL).LT.0.0.AND.WATE.LT.(-WT(LL))) GO TO 1320 WT(LL)=AMAX1(WATE,0.15) IF (ICENT.NE.1) PHAZ=RTOD*ATAN2(SUMNUM(LL),SUMDEN(LL)) IF (ICENT.EQ.1) PHAZ=90.0-SIGN(90.0,SUMNUM(LL)) IF (PHAZ.LE.0.0) PHAZ=PHAZ+360.0 IPHAZ(LL)=PHAZ+0.5 1320 ALPHA(LL)=ALFA IF (TEST) PALF(LL)=EALF(LL)*EALF(LL)+TALF(LL) 1340 IF (LI.GT.LS) GO TO 1490 DO 1450 JJ=LI,LS IL=IPH1(JJ)/32768-16384 ILA=IABS(IL) IR=IPH2(JJ)/32768-16384 IRA=IABS(IR) IF (ISTAGE-NSTAGE.LE.0) GO TO 1342 IF (SCMK(ILA).LT.0.0.OR.SCMK(IRA).LT.0.0) GO TO 1450 1342 IP=15*(IPH2(JJ)-32768*(IPH2(JJ)/32768)) IF (ABS(WT(IRA)).LT.0.1) GO TO 1350 EE=EEE(JJ)*ABS(WT(IRA)*WT(LL)) IF (TEST) VECX=EE*VEC(EEE(JJ)) IF (TEST) EALF(ILA)=EALF(ILA)+VECX IF (TEST) TALF(ILA)=TALF(ILA)+EE*EE-VECX*VECX IF (ICENT.EQ.1) GO TO 1345 IFR=ISIGN(IPHAZ(IRA),IR) IARG=MOD(1440-(IFR-IPHAZ(LL)+IP)*ISIGN(1,IL),360)+1 SUMNUM(ILA)=SUMNUM(ILA)+EE*STABLE(IARG) SUMDEN(ILA)=SUMDEN(ILA)+EE*CTABLE(IARG) GO TO 1350 1345 IF (MOD(IPHAZ(IRA)+IPHAZ(LL)+IP,360).NE.0) EE=-EE SUMNUM(ILA)=SUMNUM(ILA)+EE 1350 IF (ABS(WT(ILA)).LT.0.1) GO TO 1450 EE=EEE(JJ)*ABS(WT(ILA)*WT(LL)) IF (TEST) VECX=EE*VEC(EEE(JJ)) IF (TEST) EALF(IRA)=EALF(IRA)+VECX IF (TEST) TALF(IRA)=TALF(IRA)+EE*EE-VECX*VECX IF (ICENT.EQ.1) GO TO 1440 IFL=ISIGN(IPHAZ(ILA),IL) IARG=MOD(1440-(IFL-IPHAZ(LL)+IP)*ISIGN(1,IR),360)+1 SUMNUM(IRA)=SUMNUM(IRA)+EE*STABLE(IARG) SUMDEN(IRA)=SUMDEN(IRA)+EE*CTABLE(IARG) GO TO 1450 1440 IF (MOD(IPHAZ(ILA)+IPHAZ(LL)+IP,360).NE.0) EE=-EE SUMNUM(IRA)=SUMNUM(IRA)+EE 1450 CONTINUE 1490 SUMNUM(LL)=0.0 SUMDEN(LL)=0.0 EALF(LL)=0.0 TALF(LL)=0.0 1500 CONTINUE C FASTAN CONTROL STATEMENTS IF (NCYCLE.LT.6) GO TO 1000 IF (ISTAGE-NSTAGE.LE.0) GO TO 1510 NSTAGE=NSTAGE+1 DO 1505 I=1,NUMB IF (WT(I).GT.0.9) MKANG(I)=-IABS(MKANG(I)) 1505 CONTINUE 1510 IF (NNN.EQ.NDET) GO TO 1530 IF (IFOM.NE.0) GO TO 1520 C CALCULATE FIRST EARLY FIGURE OF MERIT CALL EFOM(NNN,IREJ,VALUE) IF (IREJ.EQ.1) NUMREJ=NUMREJ+1 IF (IFAST.EQ.0) GO TO 1515 IF (NCUT1.GT.10) GO TO 1515 SCUT1=SCUT1+VALUE NCUT1=NCUT1+1 IF (NCUT1.NE.10) GO TO 1515 CUT1=SCUT1/FLOAT(NCUT1) DO 1512 ICU=1,NSX FOM(ICU)=CUT1 1512 CONTINUE 1513 FORMAT(/1X,'AFTER 10 SETS, THE CUTOFF FOR F-EARLY', 1' FIGURE - MERIT HAS BEEN CHANGED TO',F6.3/) 1515 IF (IREJ.EQ.1) GO TO 5000 1520 NNN=NDET GO TO 1000 1530 IF (.NOT.(IFOM.LE.0.AND.(NCYCLE.EQ.6.OR.NCYCLE.EQ.9))) 1 GO TO 1550 C CALCULATE SECOND EARLY FIGURE OF MERIT CALL EFOM(NDET,IREJ,VALUE) IF (IREJ.EQ.0) GO TO 1550 NUMREJ=NUMREJ+1 GO TO 5200 1550 NALF=NALF+1 IF(NALF.GT.20) IREJ=1 IF(NALF.GT.20) RETURN IF ((SALF-SUMALF)/SALF.GT.0.02.AND.MARK.EQ.0) GO TO 1000 IF (MARK.NE.0) GO TO 1700 DO 1600 LL=1,NUMB MKANG(LL)=IABS(MKANG(LL)) 1600 CONTINUE 1700 MARK=MARK+1 C 2 CYCLES OF REFINING ALL PHASES AT END IF (MARK.LE.2) GO TO 1000 C CALCULATE FINAL F.O.M.S AND OUTPUT RESULTS 4700 RESID = 0.0 SUMEO = 0.0 SUMALF = 0.0 NUNDET = NDET-NUMB ALFEST=0.0 DO 4920 LL=1,NUMB IF (INT(100.0*WT(LL)) .EQ.(-IWMIN)) NUNDET = NUNDET + 1 IF (ABS(WT(LL)).LT.0.05) NUNDET=NUNDET+1 IF (ABS(WT(LL)).LT.0.05) GO TO 4920 ALPHA(LL) = SQRT(ALPHA(LL)) PALF(LL) = SQRT(PALF(LL)) ALFEST = ALFEST + PALF(LL) SUMALF = SUMALF + ALPHA(LL) IF (IPHAZ(LL) .LE. 0) IPHAZ(LL) = IPHAZ(LL) + 360 SUMEO = SUMEO + PALF(LL) 4920 CONTINUE C CALCULATE ABSOLUTE FIGURE OF MERIT ABSFOM = (SUMALF - ALFRAN) / (ALFEST - ALFRAN) C CALCULATE FINAL PSI ZERO FIGURE OF MERIT CALL EFOM(NDET,I,PSIZRO) PSIZRO = PSIZRO / AMIN1(1.3,ABSFOM) C CALCULATE A SCALED RESIDUAL SC = 1.0 IF (IHVY.EQ.1) SC = AMIN1(1.3,SQRT(AMAX1(ABSFOM,1.0))) DO 4930 LL=1,NUMB IF (ABS(WT(LL)).LT.0.05) GO TO 4930 RESID=RESID+ABS(SC*PALF(LL)-ALPHA(LL)) 4930 CONTINUE IF (SUMEO.LE.0.1) RESID = 100.0 IF (SUMEO.GT.0.1) RESID = 100.0 * RESID / SUMEO IF (NCUT1.EQ.10) WRITE (6,1513) CUT1 IF (PSIMIN.LT.PSIZRO.OR.RMIN.LT.RESID) GO TO 4953 PSIMIN=PSIZRO RMIN=RESID 4953 NF=NUMSET IF (NF.GT.ISKIP+10) GO TO 4955 TFOM(1,NF-ISKIP)=ABSFOM TFOM(2,NF-ISKIP)=PSIZRO TFOM(3,NF-ISKIP)=RESID NUD(NF-ISKIP)=NUNDET C REJECT SET IF TOO FEW PHASES DETERMINED 4955 IF (NUNDET.GE.NDET/3) IREJ=1 IF (NUNDET.GE.NDET/3) RETURN WRITE (2) NUMSET,ABSFOM,PSIZRO,RESID, 1 (IPHAZ(I),WT(I),I=1,NUMB),NUNDET C TEST FOR ACCEPTABLE SOLUTION IF (PSIZRO.LT.AMN(2)) AMN(2) = PSIZRO + 0.01 IF (RESID.LT.AMN(3)) AMN(3) = RESID + 0.1 IF (PSIZRO.GT.1.30.OR.PSIZRO.GT.AMN(2)) RETURN IF (RESID.GT.21.0.OR.RESID.GT.AMN(3)) RETURN IREJ = -1 RETURN C OUTPUT RELEVANT REJECTION MESSAGE 5000 IF (LIST.GE.0) WRITE (6,5100) NUMSET,VALUE 5100 FORMAT (1H ,12X,I4,10H REJECTED,F9.3) RETURN 5200 IF (LIST.GE.0) WRITE (6,5300) NUMSET,VALUE 5300 FORMAT (1H ,12X,I4,10H REJECTED,9X,F9.3) RETURN END C----------------------------------------------------------------------- C CALCULATE BOTH EARLY FIGURES OF MERIT AND FINAL PSI ZERO SUBROUTINE EFOM(NNN,IREJ,VALUE) REAL*4 EEE(2400000) C DIMENSION STATEMENT PARTICULAR TO SUBROUTINE EFOM DIMENSION CTABLE(360) COMMON /LOCAL/ AMX(3),AMN(3),LINE(20),LINEX(20) COMMON /USER/ IPATH,MS,LIST,NSREQ,PROB,NSPEC,NGEN,NANY,KARL,KMIN, 1 NINPUT,IMK,ITAN,IPUB,IFOM,ISKIP,WTFOM(3),CUT1,CUT2,ICONV(7500), 2 KMAX,IWMIN,NRAN,ISOL,IOFR,IFAST COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000),ALPHA(15000),WT(15000) COMMON /B2/ IPH2(2400000),IPHAZ(15000),IORDE(15000) COMMON /BA/ EEE COMMON /B3/ EALF(15000),TALF(15000),RALF(15000),ISPZRO(2000), 1 FOM(8000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * C EQUIVALENCE STATEMENT PARTICULAR TO SUBROUTINE EFOM EQUIVALENCE (CTABLE(1),STABLE(91)) IREJ=0 PSIZRO=0.0 RANPSI=0.0 VALUE=2.0 N=IZRO IF (N.EQ.0) RETURN C CALCULATE A PSI ZERO FIGURE OF MERIT DO 1500 I=1,N LL=I+NUMB LI=LIM(LL)+1 LS=LIM(LL+1) IF (LI.GT.LS) GO TO 1500 TOP=0.0 BOT=0.0 RAN=0.0 DO 1100 JJ=LI,LS IL=IPH1(JJ)/32768-16384 ILA=IABS(IL) IF (ABS(WT(ILA)).LT.0.1) GO TO 1100 IR=IPH2(JJ)/32768-16384 IRA=IABS(IR) IF (ABS(WT(IRA)).LT.0.1) GO TO 1100 EE=EEE(JJ)*ABS(WT(ILA)*WT(IRA)) RAN=RAN+EE*EE IP=15*(IPH2(JJ)-32768*(IPH2(JJ)/32768)) IF (ICENT.EQ.1) GO TO 1050 IFL=ISIGN(IPHAZ(ILA),IL) IFR=ISIGN(IPHAZ(IRA),IR) IARG=MOD(IFL+IFR+IP+1440,360)+1 TOP=TOP+EE*STABLE(IARG) BOT=BOT+EE*CTABLE(IARG) GO TO 1100 1050 IF (MOD(IPHAZ(ILA)+IPHAZ(IRA)+IP,360).NE.0) EE=-EE TOP=TOP+EE 1100 CONTINUE PSIZRO=PSIZRO+SQRT(TOP*TOP+BOT*BOT) RANPSI=RANPSI+SQRT(RAN) 1500 CONTINUE IF (RANPSI.GT.0.1) VALUE=PSIZRO/RANPSI IF (NNN.EQ.NDET) GO TO 2200 1710 IF (VALUE.LT.CUT1) GO TO 1900 IREJ=1 RETURN 1900 DO 2000 I=2,NSX IF (FOM(I).LT.VALUE) GO TO 2100 FOM(I-1)=FOM(I) 2000 CONTINUE I=NSX+1 2100 FOM(I-1)=VALUE CUT1=AMAX1(FOM(1),1.3) RETURN 2200 IF (VALUE.GE.CUT2) IREJ=1 RETURN END ************************************************************************ * * * SSSSS W W TTTTTTT RRRRRR * * S S W W T R R * * S W W T R R * * SSSSS W W W T RRRRRR * * S W W W W T R R * * S S WW WW T R R * * SSSSS W W T R R * * * * PROGRAM BASED ON MULTAN-80 * * STATISTICALLY WEIGHTED TANGENT FORMULA REFINEMENT * * VERSION 1998 * ************************************************************************ SUBROUTINE SWTR(KARL,IREJ) REAL*4 EEE(2400000) C DIMENSION STATEMENT PARTICULAR TO SUBROUTINE SWTR DIMENSION CTABLE(360),SUMNUM(15000),SUMDEN(15000) COMMON /USER/ IPATH,MS,LIST,NSREQ,PROB,NSPEC,NGEN,NANY,IKARL,KMIN, 1 NINPUT,IMK,ITAN,IPUB,IFOM,ISKIP,WTFOM(3),CUT1,CUT2,ICONV(7500), 2 KMAX,IWMIN,NRAN,ISOL,IOFR,IFAST COMMON /LOCAL/ AMX(3),AMN(3),LINE(20),LINEX(20) COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000),ALPHA(15000),WT(15000) COMMON /B2/ IPH2(2400000),IPHAZ(15000),IORDE(15000) COMMON /BA/ EEE COMMON /B3/ EALF(15000),TALF(15000),RALF(15000),KNOWN(15000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) COMMON /B6/ IXRAN,IYRAN,PSIMIN,RMIN COMMON /SCMK/ SCMK(15000),MKREJ,ISTAGE COMMON /FOM/ TFOM(3,10),NUD(10),SCUT1,NCUT1,NUMREJ CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * C EQUIVALENCE STATEMENT PARTICULAR TO SUBROUTINE SWTR EQUIVALENCE (STABLE(91),CTABLE(1)) C I1/I0 (BESSEL FUNCTION) VEC(U)=U*(U+0.4807)/((U+0.8636)*U+1.3943) SCALE=SIGMA/0.09 MARK = 0 NSTAGE = 1 NNN=MIN0(NDET,NRAN) CUT=12.5 IF (KARL.EQ.1) CUT=2.0 NCYC=-2*KARL C DO NOT REFINE STARTING PHASES IF HEAVY ATOM IS IN STRUCTURE IF (IHVY.EQ.1) NCYC = 0 SALF = 0.0 NALF=0 NIN=0 IF (KARL.EQ.1) NNN=NDET C INITIALISE ARRAYS AT START OF EACH CYCLE 1000 DO 1010 I=1,NUMB SUMNUM(I)=0.0 SUMDEN(I)=0.0 EALF(I)=0.0 TALF(I)=0.0 RALF(I)=0.0 IF (NCYC.LT.0) MKANG(I)=IABS(MKANG(I)) IF (ABS(WT(I)).LT.0.1) IPHAZ(I)=-1 1010 CONTINUE SUMALF=SALF SALF=0.0 NEXT=NIN NIN=0 C CALCULATE TOP & BOTTOM OF TANGENT FORMULA FOR EACH REFLEXION DO 1250 I=1,NNN LL=IORDE(I) IF (ISTAGE-NSTAGE.GT.0.AND.SCMK(LL).LT.0.0) GO TO 1250 LI=LIM(LL)+1 LS=LIM(LL+1) IF (LI.GT.LS) GO TO 1250 DO 1100 JJ=LI,LS KN=7 IF (IPHAZ(LL).GE.0) KN=KN-1 IL=IPH1(JJ)/32768-16384 ILA=IABS(IL) IF (IPHAZ(ILA).GE.0) KN=KN-2 IF (KN.EQ.7) GO TO 1100 IR=IPH2(JJ)/32768-16384 IRA=IABS(IR) IF (IPHAZ(IRA).GE.0) KN=KN-3 IF (KN.GT.4) GO TO 1100 IF (ISTAGE-NSTAGE.LE.0) GO TO 1030 IF (SCMK(ILA).LT.0.0.OR.SCMK(IRA).LT.0.0) GO TO 1100 1030 IP=15*(IPH2(JJ)-32768*(IPH2(JJ)/32768)) VECE=VEC(EEE(JJ)) GO TO (1040,1040,1060,1050),KN 1040 EE=EEE(JJ)*ABS(WT(ILA)*WT(IRA)) VECX=EE*VECE EALF(LL)=EALF(LL)+VECX TALF(LL)=TALF(LL)+EE*EE-VECX*VECX RALF(LL)=RALF(LL)+EE*EE IFL=ISIGN(IPHAZ(ILA),IL) IFR=ISIGN(IPHAZ(IRA),IR) IARG=MOD(IFL+IFR+IP+1440,360)+1 SUMNUM(LL)=SUMNUM(LL)+EE*STABLE(IARG) SUMDEN(LL)=SUMDEN(LL)+EE*CTABLE(IARG) IF (KN.NE.1) GO TO 1100 1050 EE=EEE(JJ)*ABS(WT(ILA)*WT(LL)) VECX=EE*VECE EALF(IRA)=EALF(IRA)+VECX TALF(IRA)=TALF(IRA)+EE*EE-VECX*VECX RALF(IRA)=RALF(IRA)+EE*EE IF (KN.NE.1) IFL=ISIGN(IPHAZ(ILA),IL) IARG=MOD(1440-(IFL-IPHAZ(LL)+IP)*ISIGN(1,IR),360)+1 SUMNUM(IRA)=SUMNUM(IRA)+EE*STABLE(IARG) SUMDEN(IRA)=SUMDEN(IRA)+EE*CTABLE(IARG) IF (KN.NE.1) GO TO 1100 1060 EE=EEE(JJ)*ABS(WT(IRA)*WT(LL)) VECX=EE*VECE EALF(ILA)=EALF(ILA)+VECX TALF(ILA)=TALF(ILA)+EE*EE-VECX*VECX RALF(ILA)=RALF(ILA)+EE*EE IF (KN.NE.1) IFR=ISIGN(IPHAZ(IRA),IR) IARG=MOD(1440-(IFR-IPHAZ(LL)+IP)*ISIGN(1,IL),360)+1 SUMNUM(ILA)=SUMNUM(ILA)+EE*STABLE(IARG) SUMDEN(ILA)=SUMDEN(ILA)+EE*CTABLE(IARG) 1100 CONTINUE 1250 CONTINUE C UPDATE PHASES AT END OF CYCLE DO 1500 I=1,NNN LL=IORDE(I) IF (ISTAGE-NSTAGE.GT.0.AND.SCMK(LL).LT.0.0) GO TO 1500 IF (NCYC.EQ.(-2).AND.IPHAZ(LL).LT.0) GO TO 1500 IF (MKANG(LL).LE.0) GO TO 1490 ID=15*MKANG(LL)-14 IF (ID.EQ.1) GO TO 1300 T2=SUMNUM(LL)*STABLE(ID)+SUMDEN(LL)*CTABLE(ID) SUMNUM(LL)=T2*STABLE(ID) SUMDEN(LL)=T2*CTABLE(ID) 1300 ALFA=SUMNUM(LL)**2+SUMDEN(LL)**2 IF (ALFA.EQ.0.0) GO TO 1500 WATE=1.0 IF (ALFA.LT.25.0) WATE=0.2*SQRT(ALFA) PALF(LL)=TALF(LL)+EALF(LL)*EALF(LL) WX1 = ALFA / PALF(LL) IF (WX1.GT.1.03) WX=1.03-(WX1-1.03)*SCALE IF (WX1.GT.1.03) WX=WX/((1.2178*WX-1.0698)*WX+0.858) IF (WX.LT.WATE.AND.WX1.GT.1.03) WATE=WX IF (WT(LL).LT.0.0.AND.WATE.LT.(-WT(LL))) GO TO 1500 SALF = SALF + WATE WT(LL)=AMAX1(WATE,0.15) PHAZ=RTOD*ATAN2(SUMNUM(LL),SUMDEN(LL)) IF (PHAZ.LT.0.5) PHAZ=PHAZ+360.0 IPHAZ(LL)=PHAZ+0.5 ALPHA(LL)=ALFA IF (KARL.EQ.1.AND.WT(LL).GT.0.9) MKANG(LL)=-IABS(MKANG(LL)) 1490 NIN=NIN+1 1500 CONTINUE IF (KARL.EQ.0) GO TO 1540 C KARLE RECYCLING CONTROL STATEMENTS NCYC=NCYC+1 IF (NCYC.LE.0) GO TO 1000 IF (MARK.GT.0) GO TO 1520 IF (NIN.GT.NEXT.AND.NCYC.LT.4.AND.NIN.LT.NUMB-5) GO TO 1000 DO 1515 LL=1,NUMB MKANG(LL)=IABS(MKANG(LL)) 1515 CONTINUE 1520 MARK=MARK+1 IF (MARK.LE.2) GO TO 1000 WRITE (6,1530) NIN 1530 FORMAT(//15X,40HNUMBER OF PHASES GENERATED FOR FOURIER =,I8) RESID=0.0 ABSFOM=1.0 PSIZRO=1.0 GO TO 1890 C SWTR CONTROL STATEMENTS 1540 CUT=AMAX1(0.5*CUT,0.05) IF (CUT.GT.0.1) GO TO 1000 IF (ISTAGE-NSTAGE.LE.0) GO TO 1545 NSTAGE=NSTAGE+1 DO 1542 I=1,NUMB IF (WT(I).GT.0.9) MKANG(I)=-IABS(MKANG(I)) 1542 CONTINUE 1545 IF (NNN.EQ.NDET) GO TO 1550 NNN=MIN0(NNN+NNN/2,NDET) GO TO 1000 1550 NALF=NALF+1 IF(NALF.GT.20) GOTO 2000 IF ((SALF-SUMALF)/SALF.GT.0.02.AND.MARK.EQ.0) GO TO 1000 IF (MARK.EQ.1) GO TO 1620 DO 1600 LL=1,NUMB MKANG(LL)=IABS(MKANG(LL)) 1600 CONTINUE MARK = 1 GO TO 1000 C CALCULATE AND OUTPUT FINAL FIGURES OF MERIT 1620 ALFEST=0.0 ALFRAN=0.0 SALF=0.0 SUMEO=0.0 RESID=0.0 NUNDET=NDET-NUMB DO 1700 I=1,NUMB IF (ABS(WT(I)).LT.0.05.OR.INT(100.0*WT(I)).EQ.(-IWMIN)) 1 NUNDET=NUNDET+1 IF (ABS(WT(I)).LT.0.05) GO TO 1700 ALPHA(I)=SQRT(ALPHA(I)) PALF(I)=SQRT(PALF(I)) ALFEST=ALFEST+PALF(I) ALFRAN=ALFRAN+SQRT(RALF(I)) SALF=SALF+ALPHA(I) SUMEO=SUMEO+PALF(I) 1700 CONTINUE C CALCULATE ABSOLUTE FIGURE OF MERIT ABSFOM = (SALF-ALFRAN)/(ALFEST-ALFRAN) C CALCULATE FINAL PSIZERO FIGURE OF MERIT CALL EFOM(NDET,I,PSIZRO) PSIZRO = PSIZRO / AMIN1(1.3,ABSFOM) C CALCULATE A SCALED RESIDUAL SC = 1.0 IF (IHVY.EQ.1) SC = AMIN1(1.3,SQRT(AMAX1(ABSFOM,1.0))) DO 1720 LL=1,NUMB IF (ABS(WT(LL)).LT.0.05) GO TO 1720 RESID=RESID+ABS(SC*PALF(LL)-ALPHA(LL)) 1720 CONTINUE IF (SUMEO.LE.0.1) RESID = 100.0 IF (SUMEO.GT.0.1) RESID = 100.0 * RESID / SUMEO IF (PSIMIN.LT.PSIZRO.OR.RMIN.LT.RESID) GO TO 1885 PSIMIN=PSIZRO RMIN=RESID C REJECT SET IF TOO FEW PHASES DETERMINED 1885 IF (NUNDET.GE.NDET/3) GO TO 2000 C TEST FOR ACCEPTABLE SOLUTION IF (PSIZRO.LT.AMN(2)) AMN(2) = PSIZRO + 0.01 IF (RESID.LT.AMN(3)) AMN(3) = RESID + 0.1 IF (PSIZRO.GT.1.30.OR.PSIZRO.GT.AMN(2)) GO TO 1890 IF (RESID.GT.21.0.OR.RESID.GT.AMN(3)) GO TO 1890 IREJ = -1 1890 DO 1900 I=1,NUMB IF (WT(I).GT.0.05) WT(I)=1.0 1900 CONTINUE WRITE (2) NUMSET,ABSFOM,PSIZRO,RESID, 1 (IPHAZ(I),WT(I),I=1,NUMB),NUNDET RETURN 2000 IREJ=1 RETURN END C----------------------------------------------------------------------- C CHECK FOR EQUIVALENT PHASE SETS - TO AVOID DUPLICATION IN FFT SUBROUTINE COMPAR C DIMENSION STATEMENT PARTICULAR TO SUBROUTINE COMPAR DIMENSION CTABLE(360),JORDE(15000) COMMON /LOCAL/ AMX(3), AMN(3), LINE(20), LINEX(20) COMMON /USER/ IPATH,MS,LIST,NSREQ,PROB,NSPEC,NGEN,NANY,KARL,KMIN, 1 NINPUT,IMK,ITAN,IPUB,IFOM,ISKIP,WTFOM(3),CUT1,CUT2,ICONV(7500), 2 KMAX,IWMIN,NRAN,ISOL,IOFR,IFAST COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000),FM(7500,4) COMMON /B2/ IPH2(2400000),IPHAZ(15000),IORDE(15000) COMMON /B3/ KNOWN(60000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) COMMON /FOM/TFOM(3,10),NUD(10),SCUT1,NCUT1,NUMREJ CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * C EQUIVALENCE STATEMENT PARTICULAR TO SUBROUTINE COMPAR EQUIVALENCE (STABLE(91),CTABLE(1)) DO 50 I=1,15000 JORDE(I)=IORDE(I) 50 CONTINUE FM(1,4)=3.0 IF (NUMSET .EQ. 1) GO TO 1050 C COMPUTE COMBINED FIGURES OF MERIT AND OUTPUT SUMMARY OF RESULTS REWIND 2 READ (2) READ (2) C INITIALISE AMX,AMN AND NORMALISE CFOM TO 3.0 IF (IZRO.EQ.0) WTFOM(2) = 0.0 FACTOR = 3.0 / (WTFOM(1)+WTFOM(2)+WTFOM(3)) DO 80 I=1,3 AMX(I)=-1.0E20 AMN(I)=1.0E20 WTFOM(I)=WTFOM(I)*FACTOR 80 CONTINUE DO 120 I=1,NUMSET READ (2) J,(FM(I,J),J=1,3) DO 100 J=1,3 AMX(J) = AMAX1(AMX(J), FM(I,J)) AMN(J) = AMIN1(AMN(J), FM(I,J)) 100 CONTINUE 120 CONTINUE WRITE (6,140) AMX,AMN,WTFOM 140 FORMAT(//25X,28(1H-)//14X,'SUMMARY OF FIGURES ', 1 'OF MERIT OUTPUT BY TANGENT FORMULA'//30X,7HABS FOM,9X, 2 8HPSI ZERO,9X,5HRESID//7X,13HMAXIMUM VALUE,F16.3,F17.3,F15.3// 3 7X,13HMINIMUM VALUE,F16.3,F17.3,F15.3//6X,16HRELATIVE WEIGHTS, 4 F13.2,F17.2,F15.2/5X,18H(FOR COMBINED FOM)//48X,'AVER. DEVIATI', 5 'ON'/2X,'SET UNDET. ABS PSIZERO RESIDUAL COMBINED OF TRIP', 6 'LE PHASES REMARK'/2X, 7 'NO. PHASES FOM FOM FOM FOM FROM 0 OR PI'/) IF (AMX(1) .EQ. AMN(1)) AMN(1) = 0.0 IF (AMX(2) .EQ. AMN(2)) AMX(2) = 100.0 IF (AMX(3) .EQ. AMN(3)) AMX(3) = 100.0 DO 180 I=1,NUMSET FMABS=FM(I,1) IF (FMABS.GT.1.0) FMABS=2.0-FMABS IF (FMABS.LT.0.0) FMABS=AMN(1) FM(I,4) = WTFOM(1) * (FMABS - AMN(1)) / (AMX(1) - AMN(1)) + 1 WTFOM(2) * (AMX(2) - FM(I,2)) / (AMX(2) - AMN(2)) + 2 WTFOM(3) * (AMX(3) - FM(I,3)) / (AMX(3) - AMN(3)) 180 CONTINUE IREC = 100 ISET = 0 JSET = 0 C ALLOW AVERAGE DIFFERENCE OF ARCSIN(0.034) TEST = 0.034*FLOAT(LIM(NUMB+1)) REWIND 2 READ (2) DO 1000 I=1,NUMSET CALL RTAPE(IPHAZ,IREC,ISET,I,NUMB,NAMI,IUND) 400 FORMAT(1X,I4,I6,F8.3,F7.3,F9.3,F10.3,6X,F7.3) IF (ICENT.EQ.1) GO TO 450 IF (FM(I,4).LT.0.0.OR.LIST.LT.0.AND.FM(I,4).LT.2.0) GO TO 450 CALL TRIPLE(AVER) 450 IF (FM(I,4).LT.0.0 .OR. I.EQ.NUMSET) GO TO 950 NS = I+1 DO 900 J=NS,NUMSET IF (FM(J,4) .LT. 0.0) GO TO 900 C COMPARE SETS WITH SIMILAR FOMS IF (ABS(FM(J,1)-FM(I,1)) .GT. 0.05) GO TO 900 IF (ABS(FM(J,2)-FM(I,2)) .GT. 0.05) GO TO 900 IF (ABS(FM(J,3)-FM(I,3)) .GT. 0.4) GO TO 900 IF (J .NE. JSET) CALL RTAPE(JORDE,IREC,JSET,J,NUMB,NAMJ,JA) TESTI = 0.0 TESTE = 0.0 DO 600 K=1,NUMB LI = LIM(K)+1 LS = LIM(K+1) IF (LI .GT. LS) GO TO 600 DO 500 JJ=LI,LS IL=IPH1(JJ)/32768-16384 ILA = IABS(IL) IR=IPH2(JJ)/32768-16384 IRA = IABS(IR) IP = 15*(IPH2(JJ)-32768*(IPH2(JJ)/32768)) IPI = IPHAZ(K)-ISIGN(IPHAZ(ILA),IL)-ISIGN(IPHAZ(IRA),IR)-IP IPJ = JORDE(K)-ISIGN(JORDE(ILA),IL)-ISIGN(JORDE(IRA),IR)-IP IARG = MOD(IPI-IPJ+3600,360)+1 TESTI = TESTI+1.0-CTABLE(IARG) IARG = MOD(IPI+IPJ+3600,360)+1 TESTE = TESTE+1.0-CTABLE(IARG) IF (TESTI .GT. TEST .AND. TESTE .GT. TEST) GO TO 900 500 CONTINUE 600 CONTINUE FM(J,4) = -FLOAT(NAMI) 900 CONTINUE 950 IEQ = INT(-FM(I,4)) IF (ICENT.EQ.1) GO TO 850 IF (FM(I,4).LT.0.0.OR.LIST.LT.0.AND.FM(I,4).LT.2.0) GO TO 850 800 FORMAT(1X,I4,I6,F8.3,F7.3,F9.3,F10.3,6X,F7.3,5X,'PSEUDO-CENTRIC') 820 FORMAT(1X,I4,I6,F8.3,F7.3,F9.3,F10.3,6X,F7.3) IF (LIST.GE.0.AND.AVER.LT.15.0 1 .OR.LIST.LT.0.AND.FM(I,4).GE.2.0.AND.AVER.LT.15.0) 2 WRITE (6,800) NAMI,IUND,(FM(I,J),J=1,4),AVER IF (LIST.GE.0.AND.AVER.GE.15.0 1 .OR.LIST.LT.0.AND.FM(I,4).GE.2.0.AND.AVER.GT.15.0) 2 WRITE (6,820) NAMI,IUND,(FM(I,J),J=1,4),AVER GO TO 860 850 IF (LIST.GE.0.OR.LIST.LT.0.AND.FM(I,4).GE.2.0) 1 WRITE (6,400) NAMI,IUND,(FM(I,J),J=1,4) 860 IF (LIST.GE.0.AND.FM(I,4) .LT. 0.0) WRITE (6,960) IEQ 960 FORMAT(1X,60X,5H= SET,I4) 1000 CONTINUE CALL RTAPE(IPHAZ,IREC,ISET,NUMSET,NUMB,NAMI,JA) 1050 IF (KARL.EQ.1.OR.IMK.GT.0) GO TO 1120 ISET01=ISKIP+1 WRITE (6,1100) ISET01,NSREQ 1100 FORMAT(/1X,16X,31HPHASE DEVELOPED FROM SET NUMBER,I6,3H TO,I6/) IF (NUMREJ.GT.0) WRITE (6,1110) NUMREJ 1110 FORMAT(48X,I4,14H SETS REJECTED/) 1120 NIX=-1 WRITE (2) NIX WRITE (2) NUMSET,(FM(I,4),I=1,NUMSET) RETURN END C----------------------------------------------------------------------- C POSITION TAPE FOR READING SET I SUBROUTINE RTAPE(IA,IREC,ISET,I,NUMB,NAME,NUND) DIMENSION IA(NUMB) ISET = I IF (I .GE. IREC) GO TO 10 IREC = -1 REWIND 2 10 IREC = IREC+1 IF (IREC .GT. I) GO TO 20 READ (2) GO TO 10 20 READ (2) NAME,A,A,A,(IA(K),A,K=1,NUMB),NUND RETURN END C----------------------------------------------------------------------- C CHECK FIGURES OF MERIT FOR 10 SETS. SUBROUTINE MFOM(ISW) DIMENSION REST(3,5) COMMON /USER/ IPATH,MS,LIST,NSREQ,PROB,NSPEC,NGEN,NANY,KARL,KMIN, 1 NINPUT,IMK,ITAN,IPUB,IFOM1,ISKIP,WTFOM(3),CUT1,CUT2,ICONV(7500), 2 KMAX,IWMIN,NRAN,ISOL,IOFR,IFAST COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /FOM/TFOM(3,10),NUD(10),SCUT1,NCUT1 DO 100 I=1,3 DO 100 J=1,10 IF (J.NE.1) GO TO 50 REST(I,1)=TFOM(I,J) REST(I,2)=TFOM(I,J) REST(I,3)=TFOM(I,J) GO TO 100 50 IF (REST(I,1).LT.TFOM(I,J)) REST(I,1)=TFOM(I,J) IF (REST(I,2).GT.TFOM(I,J)) REST(I,2)=TFOM(I,J) REST(I,3)=REST(I,3)+TFOM(I,J) 100 CONTINUE DO 200 I=1,3 REST(I,3)=REST(I,3)/10.0 REST(I,4)=0.0 REST(I,5)=0.0 200 CONTINUE DO 300 I=1,3 DO 300 J=1,10 REST(I,4)=REST(I,4)+(TFOM(I,J)-REST(I,3))**2 REST(I,5)=REST(I,5)+ABS(TFOM(I,J)-REST(I,3)) 300 CONTINUE DO 400 I=1,3 REST(I,4)=REST(I,4)/10.0 REST(I,5)=REST(I,5)/10.0 400 CONTINUE IF (ISW.NE.0) GO TO 1000 IF (REST(1,3).GT.1.1.AND.REST(1,5).LT.0.1) ISW=1 IF (REST(1,3).GT.1.25) ISW=1 IF (REST(1,5).LT.0.02) ISW=1 IF (ISW.EQ.1) ITAN=1 1000 RETURN END ************************************************************************ * * * RRRRRR EEEEEEE SSSSS OOOOO L V V * * R R E S S O O L V V * * R R E S O O L V V * * RRRRRR EEEEEE SSSSS O O L V V * * R R E S O O L V V * * R R E S S O O L V V * * R R EEEEEEE SSSSS OOOOO LLLLLLL V * * * * RESOLVING ENANTIOMORPHOUS AMBIGUITIES * * BEIJING 1985 * ************************************************************************ C SUBROUTINE RESOLV REAL*4 EEE(2400000) DIMENSION KDSTOR(250) COMMON /LOCAL/ AMX(3),AMN(3),LINE(20),LINEX(20) COMMON /USER/ IPATH,MS,LIST,NSREQ,PROB,NSPEC,NGEN,NANY,KARL,KMIN, 1 NINPUT,IMK,ITAN,IPUB,IFOM,ISKIP,WTFOM(3),CUT1,CUT2,ICONV(7500), 2 KMAX,IWMIN,NRAN,ISOL,IOFR,IFAST COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000),ALPHA(15000),WT(15000) COMMON /B2/ IPH2(2400000),IPHAZ(15000),IORDE(15000) COMMON /BA/ EEE COMMON /B3/ EALF(15000),TALF(15000),RALF(15000),ISPZRO(2000), 1 FOM(8000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) COMMON /B5/ JPB(1000),JPHP(1000),JPHQ(1000),WTQ(1000),PP(1000) COMMON /B6/ IXRAN,IYRAN COMMON /SCMK/ SCMK(15000),MKREJ,ISTAGE CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * C I1/I0 (BESSEL FUNCTIONS) c VEC(U)=U*(U+0.4807)/((U+0.8636)*U+1.3943) NSETS=0 IXRAN = 1 IYRAN = 1 NSREQ = NSREQ +ISKIP NUBSET = 0 WRITE (6,60) ITLE 60 FORMAT(//1X,23HPHASE PART 2 --- RANTAN,10X,'DERIVATION OF SIGN', 1'S FOR PHASE DIFFERENCES'/55X,20H VERSION 1998//80A1/) WRITE (6,65) NDET,LIM(NUMB+1) 65 FORMAT(11X,I5,33H REFLEXIONS TO BE DETERMINED WITH, 1 I8,14H RELATIONSHIPS) DO 80 I=1,NUMB EALF(I)=E(I) IF (ISTAGE.EQ.2) EALF(I)=E(I)/ABS(SCMK(I)) 80 CONTINUE REWIND 2 MARK = 0 NCENT = MAX0(ICENT,0) WRITE (2) MARK WRITE (2) ITLE, NCENT, LATT, NSYM, 1 ((TS(I,J),(IS(K,I,J),K=1,3),I=1,3),J=1,NSYM), MAXH,PARA,NAT,NUMB, 2 (IH(I),EALF(I),I=1,NUMB) REWIND 4 READ (4,90) 90 FORMAT(/) READ (4,100) (MKG(I),WTQ(I),JPHQ(I),JPHP(I),I=1,NUMB) 100 FORMAT(I5,36X,F7.4,2I5) DO 220 I=1,NUMB MKANG(I)=IABS(MKANG(I)) ID=15*MKANG(I)-14 IF (ID.NE.1) JPHP(I)=0 220 CONTINUE WRITE (6,250) (MKG(I),JPHQ(I),JPHP(I),WTQ(I),I=1,NUMB) 250 FORMAT(//24X,35HPHASE INFORMATION INPUT FROM PREPAR,//1X, 13(2X,22H CODE PHQ PHD WEIGHT),/3(2X,I5,I6,I5,1X,F5.2)) C READ SPECIFIED SET NUMBERS IF (IPUB.GT.0) READ (4,300) (KDSTOR(I),I=1,IPUB) 300 FORMAT(20I4) IF (LIST.GE.0) WRITE (6,350) 350 FORMAT(//44X,'AVERAGE DEVIATION'/9X,16HFIGURES OF MERIT, 1 3X,12HUNDETERMINED,6X,'FROM 0 OR 180',7X,7HREMARKS/ 2 2X,3HSET,3X,3HABS,3X,7HPSIZERO,2X,5HRESID,3X,6HPHASES, 3 7X,'FOR ALL TRIPLETS') 400 NSETS = NSETS + 1 IF (IPUB.GT.0.AND.NSETS.GT.IPUB) GO TO 1000 IF (IPUB.GT.0) ISETX = KDSTOR(NSETS) 450 NUMSET = NUMSET + 1 IF (NUMSET.GT.NSREQ) GO TO 1000 C PERMUTE RANDOM SIGN TO DELTA PHASE DO 650 I=1,NUMB PP(I)=0.6 RANDTT=RRAND(IXRAN,IYRAN) IF (RANDTT.LT.0.5) PP(I)=0.4 IF (JPHP(I).EQ.0) PP(I)=1.0 IF (ISTAGE.EQ.2.AND.SCMK(I).LT.0.0) PP(I)=RANDTT 650 CONTINUE IF (NUMSET .LE.ISKIP.OR.NUMSET.LT.ISETX) GO TO 450 CALL DETSIGN GO TO 400 1000 NUMSET = NSETS-1 RETURN END C----------------------------------------------------------------------- C DERIVATION OF SIGNS FOR PHASE DIFFERENCES SUBROUTINE DETSIGN REAL*4 EEE(2400000) DIMENSION CTABLE(360),SUMDEN(15000),SUMNUM(15000) COMMON /LOCAL/ AMX(3),AMN(3),LINE(20),LINEX(20) COMMON /USER/ IPATH,MS,LIST,NSREQ,PROB,NSPEC,NGEN,NANY,KARL,KMIN, 1 NINPUT,IMK,ITAN,IPUB,IFOM,ISKIP,WTFOM(3),CUT1,CUT2,ICONV(7500), 2 KMAX,IWMIN,NRAN,ISOL,IOFR,IFAST COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000),ALPHA(15000),WT(15000) COMMON /B2/ IPH2(2400000),IPHAZ(15000),IORDE(15000) COMMON /BA/ EEE COMMON /B3/ EALF(15000),TALF(15000),RALF(15000),ISPZRO(2000), 1 FOM(8000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) COMMON /B5/JPB(1000),JPHP(1000),JPHQ(1000),WTQ(1000),PP(1000) COMMON /B6/ IXRAN,IYRAN COMMON /SCMK/ SCMK(15000),MKREJ,ISTAGE CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * C EQUIVALENCE STATEMENT PARTICULAR TO SUBROUTINE DSIGN EQUIVALENCE (STABLE(91),CTABLE(1)) C I1/I0 (BESSEL FUNCTION) VEC(U)=U*(U+0.4807)/((U+0.8636)*U+1.3943) MARK = 0 SALF=0.0 NCYC=0 1000 DO 1010 I=1,NUMB SUMNUM(I)=0.0 SUMDEN(I)=0.0 EALF(I)=0.0 TALF(I)=0.0 RALF(I)=0.0 PALF(I)=0.0 WT(I)=WTQ(I)*SQRT(2.0*PP(I)*(PP(I)-1.0)*(1.0-CTABLE(1+ 1 MOD(2*JPHP(I),360)))+1.0) JPB(I)=RTOD*ATAN2((2.0*PP(I)-1.0)*STABLE(1+IABS(JPHP(I))), 1 CTABLE(1+JPHP(I))) IPHAZ(I)=MOD(JPB(I)+360,360) 1010 CONTINUE NCYC=NCYC+1 SUMALF=SALF SALF=0.0 NIN=0 C CALCULATE TOP & BOTTOM OF TANGENT FORMULA FOR EACH REFLEXION DO 1250 I=1,NDET LL=IORDE(I) LI=LIM(LL)+1 LS=LIM(LL+1) IF (LI.GT.LS) GO TO 1250 DO 1100 JJ=LI,LS IL=IPH1(JJ)/32768-16384 ILA=IABS(IL) IR=IPH2(JJ)/32768-16384 IRA=IABS(IR) IF (ISTAGE.EQ.2.AND.SCMK(LL).LT.0.0) GO TO 1100 IF (ISTAGE.EQ.2.AND.SCMK(ILA).LT.0.0) GO TO 1100 IF (ISTAGE.EQ.2.AND.SCMK(IRA).LT.0.0) GO TO 1100 IF (JPHP(LL).NE.0.AND.JPHP(ILA).NE.0.AND.JPHP(IRA).NE.0) 1 GO TO 1100 IP=15*(IPH2(JJ)-32768*(IPH2(JJ)/32768)) JPQL=ISIGN(JPHQ(ILA),IL) JPQR=ISIGN(JPHQ(IRA),IR) IPQ=IP IP=MOD(IPQ-JPHQ(LL)+JPQL+JPQR+720,360) VECE=VEC(EEE(JJ)) EE=EEE(JJ)*ABS(WT(ILA)*WT(IRA)) VECX=EE*VECE EALF(LL)=EALF(LL)+VECX TALF(LL)=TALF(LL)+EE*EE-VECX*VECX RALF(LL)=RALF(LL)+EE*EE IFL=ISIGN(IPHAZ(ILA),IL) IFR=ISIGN(IPHAZ(IRA),IR) IARG=MOD(IFL+IFR+IP+1440,360)+1 SUMNUM(LL)=SUMNUM(LL)+EE*STABLE(IARG) SUMDEN(LL)=SUMDEN(LL)+EE*CTABLE(IARG) 1050 EE=EEE(JJ)*ABS(WT(ILA)*WT(LL)) VECX=EE*VECE EALF(IRA)=EALF(IRA)+VECX TALF(IRA)=TALF(IRA)+EE*EE-VECX*VECX RALF(IRA)=RALF(IRA)+EE*EE IARG=MOD(1440-(IFL-IPHAZ(LL)+IP)*ISIGN(1,IR),360)+1 SUMNUM(IRA)=SUMNUM(IRA)+EE*STABLE(IARG) SUMDEN(IRA)=SUMDEN(IRA)+EE*CTABLE(IARG) 1060 EE=EEE(JJ)*ABS(WT(IRA)*WT(LL)) VECX=EE*VECE EALF(ILA)=EALF(ILA)+VECX TALF(ILA)=TALF(ILA)+EE*EE-VECX*VECX RALF(ILA)=RALF(ILA)+EE*EE IARG=MOD(1440-(IFR-IPHAZ(LL)+IP)*ISIGN(1,IL),360)+1 SUMNUM(ILA)=SUMNUM(ILA)+EE*STABLE(IARG) SUMDEN(ILA)=SUMDEN(ILA)+EE*CTABLE(IARG) 1100 CONTINUE 1250 CONTINUE C UPDATE PHASES AT END OF CYCLE DO 1500 I=1,NDET LL=IORDE(I) ID=15*MKANG(LL)-14 IF (ID.EQ.1) GO TO 1300 T2=SUMNUM(LL)*STABLE(ID)+SUMDEN(LL)*CTABLE(ID) SUMNUM(LL)=T2*STABLE(ID) SUMDEN(LL)=T2*CTABLE(ID) 1300 ALFA=SUMNUM(LL)**2+SUMDEN(LL)**2 IF (ALFA.LT.0.000001) GO TO 1500 IF (ISTAGE.EQ.2.AND.SCMK(LL).LT.0.0) GO TO 1500 IF (MKANG(LL).LT.0) GO TO 1490 IF (JPHP(LL).EQ.0) GO TO 1490 PP(LL)=0.5+0.5*TANH(STABLE(1+IABS(JPHP(LL)))*SUMNUM(LL)) 1490 PALF(LL)=TALF(LL)+EALF(LL)*EALF(LL) ALPHA(LL)=ALFA SALF=SALF+ALFA NIN=NIN+1 1500 CONTINUE IF (NCYC.GT.10) GO TO 1600 IF (NCYC.LT.3) GO TO 1000 IF ((SALF-SUMALF)/SALF.GT.0.02) GO TO 1000 1600 IF (ISTAGE.NE.2) GO TO 1700 DO 1650 J=1,NUMB I=IORDE(J) IF (SCMK(I).GT.0.0) IPHAZ(I)=MOD(JPHQ(I)+JPB(I)+360,360) IF (SCMK(I).GT.0.0.AND.PP(I).GT.0.95) MKANG(I)=-IABS(MKANG(I)) IF (SCMK(I).LT.0.0) IPHAZ(I)=INT(PP(I)*360.0+0.5) IF (SCMK(I).LT.0.0) WT(I)=-0.01*FLOAT(IWMIN) IF (IPHAZ(I).EQ.0) IPHAZ(I)=360 IF (J.GT.NDET) WT(I)=0.0 1650 CONTINUE CALL SWTR(0,IREJ) RETURN C CALCULATE AND OUTPUT FINAL FIGURES OF MERIT 1700 ALFEST=0.0 ALFRAN=0.0 SALF=0.0 SUMEO=0.0 RESID=0.0 DO 1750 J=1,NDET I=IORDE(J) WT(I)=WTQ(I)*SQRT(2.0*PP(I)*(PP(I)-1.0)*(1.0-CTABLE(1+ 1 MOD(2*JPHP(I),360)))+1.0) JPB(I)=RTOD*ATAN2((2.0*PP(I)-1.0)*STABLE(1+IABS(JPHP(I))), 1 CTABLE(1+JPHP(I))) IPHAZ(I)=MOD(JPHQ(I)+JPB(I)+360,360) IF (IPHAZ(I).EQ.0) IPHAZ(I)=360 ALPHA(I)=SQRT(ALPHA(I)) PALF(I)=SQRT(PALF(I)) ALFEST=ALFEST+PALF(I) ALFRAN=ALFRAN+SQRT(RALF(I)) SALF=SALF+ALPHA(I) SUMEO=SUMEO+PALF(I) 1750 CONTINUE C CALCULATE ABSOLUTE FIGURE OF MERIT ABSFOM = (SALF-ALFRAN)/(ALFEST-ALFRAN) C CALCULATE FINAL PSIZERO FIGURE OF MERIT CALL EFOM(NDET,I,PSIZRO) PSIZRO = PSIZRO / AMIN1(1.3,ABSFOM) C CALCULATE A SCALED RESIDUAL SC = 1.0 IF (IHVY.EQ.1) SC = AMIN1(1.3,SQRT(AMAX1(ABSFOM,1.0))) DO 1800 I=1,NUMB RESID=RESID+ABS(SC*PALF(I)-ALPHA(I)) 1800 CONTINUE NIN=NDET-NIN IF (SUMEO.LE.0.1) RESID = 100.0 IF (SUMEO.GT.0.1) RESID = 100.0 * RESID / SUMEO CALL TRIPLE(AVER) IF (AVER.GE.15.0.AND.LIST.GE.0) 1 WRITE (6,1840) NUMSET,ABSFOM,PSIZRO,RESID,NIN,AVER 1840 FORMAT(1X,I4,F7.3,F8.3,F8.3,I7,9X,F7.2) IF (AVER.LT.15.0.AND.LIST.GE.0) 1 WRITE (6,1850) NUMSET,ABSFOM,PSIZRO,RESID,NIN,AVER 1850 FORMAT(1X,I4,F7.3,F8.3,F8.3,I7,9X,F7.2,11X,14HPSEUDO-CENTRIC) 2000 WRITE (2) NUMSET,ABSFOM,PSIZRO,RESID,(IPHAZ(I),WT(I),I=1,NUMB),NIN RETURN END C----------------------------------------------------------------------- C CHECK FOR ENANTIOMORPHOUS AMBIGUITY SUBROUTINE TRIPLE(AVER) REAL*4 EEE(2400000) COMMON /LOCAL/ AMX(3),AMN(3),LINE(20),LINEX(20) COMMON /USER/ IPATH,MI,LIST,NSREQ,PROB,NSPEC,NGEN,NANY,KARL,KMIN, 1 NINPUT,IMK,ITAN,IPUB,IFOM,ISKIP,WTFOM(3),CUT1,CUT2,ICONV(7500), 2 KMAX,IWMIN,NRAN,ISOL,IOFR COMMON /CONST/ KUSER1,KUSER2,KUSER3,KUSER4,KUSER5,KUSER6, 1 DTOR,RTOD,STABLE(450) COMMON /SYMTRY/ IS(3,3,24), TS(3,24), NSYM, LATT, ICENT, NORI COMMON /KFRAG/ NINF(10),NGP,SUM1,SUM2,IFAZQ,SIGMAQ,SUMX,SUMZ,IHVY COMMON /PARAM/ E3MIN,SIGMA,MAXH(3),NUMB,IZRO,NUMSET,NANT(4), 1 NRAL,MODUL(3),ITLE(80),NREF,ALFRAN,NREC,PARA(6),NAT,NDET,NSX COMMON /B1/ IPH1(2400000),ALPHA(15000),WT(15000) COMMON /B2/ IPH2(2400000),IPHAZ(15000),IORDE(15000) COMMON /BA/ EEE COMMON /B3/ EALF(15000),TALF(15000),RALF(15000),ISPZRO(2000), 1 FOM(8000) COMMON /B4/ IH(15000),IZ(15000),E(15000),LIM(17001),MKANG(15000), 1 MKG(15000),PALF(15000) COMMON /B6/ IXRAN,IYRAN COMMON /SCMK/ SCMK(15000),MKREJ,ISTAGE CHARACTER ITLE C * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * NREL=0 ISUMP3=0 DO 1500 I=1,NDET LL=IORDE(I) LI=LIM(LL)+1 LS=LIM(LL+1) IF (LI.GT.LS) GO TO 1500 DO 1100 JJ=LI,LS IL=IPH1(JJ)/32768-16384 ILA=IABS(IL) IR=IPH2(JJ)/32768-16384 IRA=IABS(IR) NREL=NREL+1 IP=15*(IPH2(JJ)-32768*(IPH2(JJ)/32768)) IFL=ISIGN(IPHAZ(ILA),IL) IFR=ISIGN(IPHAZ(IRA),IR) IARG=MOD(IFL+IFR+IP-IPHAZ(LL)+1440,180) IF (IARG.GT.90) IARG=180-IARG ISUMP3=ISUMP3+IARG 1100 CONTINUE 1500 CONTINUE AVER=FLOAT(ISUMP3)/FLOAT(NREL) RETURN END ************************************************************************ * * * EEEEEEE X X FFFFFFF FFFFFFF TTTTTTT * * E X X F F T * * E X X F F T * * EEEEEE X FFFFFF FFFFFF T * * E X X F F T * * E X X F F T * * EEEEEEE X X F F T * * * * MODIFICATION FROM EXFFT OF MULTAN-80 * ************************************************************************ C READ OUTPUT TAPE FROM PHASE OR PREPAR AND EXPAND DATA TO SPACE C GROUG P1 BEFORE CALLING FOURIER TRANSFORM ROUTINES SUBROUTINE EXFFT C INCLUDE 'FLIB.FD' COMMON X(130000) COMMON /REFL/ IH(100),G(2,100) COMMON /PERIF/ TWOPI,VECT(8,3),MFP,IPAT COMMON /CONST/ NEX,KUSER1,DTOR,NP(3),ALPHA,BETA,GAMA COMMON /TRAN/ SCALE,ITLE(80),MH(3) COMMON /TRANN/TL(3,4),TS(3,24),FS(3,3,24),NDIFF,MN,NALIM,MLAT,NPC COMMON /PEAKS/ NN1,NPIC,DM,XMAX(3),XX(4,400),NEP(400) COMMON /TAPE/ NOSET,PARA(6),NEQV,NCENT,LATT,NATM,IS(3,3,24) COMMON /AAPMP/ IAPA,IHAR,NHAR,MC1,NHV,XH(40),YH(40),ZH(40) COMMON /ITEM/ NN,N1,N2,B1,B2,NX,NY DIMENSION MX(40000),KX(40000),LX(40000),TTM(3,24) CHARACTER ITLE C PRELIMINARY SECTION DEFINE ALL NECESSARY PROGRAM PARAMETERS C KUSER1 = DIMENSION OF ARRAYS IHKL,E,IPHAZ,EP = MAXIMUM NUMBER C OF INDEPENDENT REFLECTIONS WHICH CAN BE INPUT (KUSER1 .GE. NUMB) C DIMENSION OF X = 3 * KUSER1 KUSER1 = 40000 NSIZE = 3 * KUSER1 - 1 DTOR = ATAN(1.0) / 45.0 TWOPI = 360.0 * DTOR CALL CCPDPN(1,'SAPIMAP','SCRATCH','U',80,0) rewind (2) c CALL CCPDPN(2,'FCOEF.TM','UNKNOWN','U',80,0) CALL CCPDPN(8,'SCRA8.TM','SCRATCH','U',80,0) c OPEN(1,FILE='SAPI98.MAP',FORM='UNFORMATTED',STATUS='UNKNOWN') c OPEN(2,FILE='FCOEF.TM',FORM='UNFORMATTED',STATUS='UNKNOWN') c OPEN(6,FILE='EXFFT.OUT',FORM='FORMATTED',STATUS='UNKNOWN') c OPEN(8,FILE='SCRA8.TM',FORM='UNFORMATTED',STATUS='UNKNOWN') CALL EXPAND (ISOL,NSIZE) CALL PP1 (X,NSIZE,NP(1),NP(2),NP(3)) CLOSE (2) IF (MFP.EQ.10) GO TO 100 C COMPUTING MINIMUM OR SUM FUNCTION CALL MINFN (LX,MX,KX,NP(1),NP(2),NP(3)) 100 IF (IPAT.EQ.0.OR.MFP.NE.10) GO TO 200 DO 150 I=1,24 DO 150 J=1,3 TTM(J,I)=TS(J,I) 150 TS(J,I)=0.0 NCENTT=NCENT NCENT=1 200 CLOSE (UNIT=8) CALL CCPDPN(8,'SAPIPKS','UNKNOWN','F',80,0) c OPEN(8,FILE='SAPI98.PKS',FORM='FORMATTED',STATUS='UNKNOWN') CALL SEARCH WRITE (8,210) NPIC 210 FORMAT(I4) DO 225 I=1,NPIC IF (XX(4,I).GT.9000.0) XX(4,I)=9000.0 WRITE (8,250) (XX(J,I),J=1,4),I 225 CONTINUE 250 FORMAT(11X,3F10.6,3X,F7.0,6X,I4) IF (IAPA.EQ.0) GO TO 400 ALPHA=DTOR*PARA(4) BETA=DTOR*PARA(5) GAMA=DTOR*PARA(6) DO 350 I=1,24 DO 350 J=1,3 350 TS(J,I)=TTM(J,I) NCENT=NCENTT C AUTOMATIC ANALYSIS OF PATTERSON MAP CALL AAPM IF (IAPA.NE.4) GO TO 400 CALL SEARCH REWIND 8 WRITE (8,210) NPIC DO 380 I=1,NPIC IF (XX(4,I).GT.9000.0) XX(4,I)=9000.0 380 WRITE (8,250) (XX(J,I),J=1,4),I 400 IF (ISOL.NE.1) GO TO 500 CALL PICKAM REWIND 8 WRITE (8,210) NPIC DO 450 I=1,NPIC IF (XX(4,I).GT.9000.0) XX(4,I)=9000.0 450 WRITE (8,250) (XX(J,I),J=1,4),I 500 continue c CLOSE (1) c CLOSE (8) END C ---------------------------------------------------------------- C MAKE NULL TAPE FOR SEARCH SUBROUTINE ERROR3 I = 0 NDIFF = -1 WRITE (1) (I,J=1,20),NDIFF,(I,J=1,226) c CLOSE (6) STOP' --- ERROR in EXFFT ---' END C ------------------------------------------------------------------ C GENERATE COMPLETE HEMISPHERE OF REFLEXION DATA SUBROUTINE EXPAND (ISOL,NSIZE) INTEGER YEAR,MONTH,DAY,HOUR,MINUTE,SECOND COMMON/DATETIME/ YEAR,MONTH,DAY,HOUR,MINUTE,SECOND COMMON IHKL(40000),E(40000),IPHAZ(40000) COMMON /REFL/ IH(100),G(2,100) COMMON /PERIF/ TWOPI,VECT(8,3),MFP,IPAT COMMON /CONST/ NEX,KUSER1,DTOR,NP(3) COMMON /TRAN/ SCALE,ITLE(80),MH(3) COMMON /TRANN/TL(3,4),TS(3,24),FS(3,3,24),NDIFF,MN,NALIM,N0,NPC COMMON /PEAKS/ N1,NPIC,DM,XMAX(3),D(4,400) COMMON /TAPE/ NOSET,PARA(6),NEQV,NCENT,LATT,NATM,IS(3,3,24) COMMON /AAPMP/ IAPA,IHAR,NHAR,MC1,NHV,XH(40),YH(40),ZH(40) DIMENSION CFOM(40000),EP(40000),I1(3),I2(3),KIND(24),TAB(15) DIMENSION LH(600),LK(600),LL(600),EW(600),ED(600),RHO(600) DIMENSION SS(3,24) CHARACTER ITLE EQUIVALENCE (IPHAZ(1),EP(1),CFOM(1)) 50 FORMAT(/37X,'E-MAP'/) 60 FORMAT(/34X,'FOURIER MAP'/) 70 FORMAT(/19X,'SUPERPOSITION OF PATTERSON AND OTHER MAPS', * /19X,'THE PATTERSON MAP WITH F*F AS COEFFICIENT'/) 72 FORMAT(/19X,'SUPERPOSITION OF PATTERSON AND OTHER MAPS', * /19X,'THE PATTERSON MAP WITH E*F AS COEFFICIENT'/) 74 FORMAT(/19X,'SUPERPOSITION OF PATTERSON AND OTHER MAPS', * /19X,'THE PATTERSON MAP WITH E*E AS COEFFICIENT'/) 80 FORMAT(/21X,'PATTERSON-MAP WITH F*F AS COEFFICIENT'/) 82 FORMAT(/21X,'PATTERSON-MAP WITH E*F AS COEFFICIENT'/) 84 FORMAT(/21X,'PATTERSON-MAP WITH E*E AS COEFFICIENT'/) 90 FORMAT(/20X,'AUTOMATIC ANALYSIS OF THE PATTERSON MAP', * /28X, 'WITH F*F AS COEFFICIENT'/) 92 FORMAT(/20X,'AUTOMATIC ANALYSIS OF THE PATTERSON MAP', * /28X, 'WITH E*F AS COEFFICIENT'/) 94 FORMAT(/20X,'AUTOMATIC ANALYSIS OF THE PATTERSON MAP', * /28X, 'WITH E*E AS COEFFICIENT'/) C INPUT DATA FROM CONTROL FILE GENERATED BY "PREPAR" rewind (20) c CALL CCPDPN(10,'EXFFKW.TM','UNKNOWN','F',80,0) c OPEN(10,FILE='EXFFKW.TM',FORM='FORMATTED',STATUS='UNKNOWN') READ (20,103) NOSET READ(20,104) ISOL,MFP,MN,IPAT,NALIM,GRID,((VECT(I,J),J=1,3),I=1,8) READ (20,105) IAPA,IHAR,NHAR,MC1,NPC,DM,(XH(I),YH(I),ZH(I),I=1,40) 103 FORMAT(/I5) 104 FORMAT(/5I4,F8.5,8(/3F10.4)) 105 FORMAT(/5I4,F8.4,10(/12F10.4)) CLOSE (20) READ (2) NDIFF IF (NDIFF.EQ.0) READ (2) ITLE, NCENT, LATT, NEQV, 1 ((TS(I,J),(IS(K,I,J),K=1,3),I=1,3),J=1,NEQV), 2 MH, PARA, NATM, NUMB, (IHKL(I),E(I), I=1,NUMB) C CHECK FOR NULL TAPE IF (NDIFF.EQ.(-1)) CALL ERROR3 IF (NDIFF.GT.0) READ (2) ITLE,NCENT,LATT,NEQV,((TS(I,J), 1 (IS(K,I,J),K=1,3),I=1,3),J=1,NEQV),MH,PARA,NATM,RHOLIM DO 112 I=1,NEQV DO 111 J=1,3 DO 110 K=1,3 FS(K,J,I)=FLOAT(IS(K,J,I)) 110 CONTINUE 111 CONTINUE 112 CONTINUE C PRINT INITIAL TIME WRITE (6,114) HOUR,MINUTE,SECOND,DAY,MONTH,YEAR WRITE (6,113) ITLE 113 FORMAT(1X,22HFAST FOURIER TRANSFORM,31X, 1 20H VERSION 1998//80A1) 114 FORMAT(///53X,I2,':',I2,':',I2,3X,I2,'/',I2,'/',I2/) NN=0 IF (NDIFF.EQ.0) GO TO 145 IF (NDIFF.EQ.1) WRITE (6,60) IF (IPAT.EQ.1.AND.IAPA.EQ.4) WRITE (6,90) IF (IPAT.EQ.2.AND.IAPA.EQ.4) WRITE (6,92) IF (IPAT.EQ.3.AND.IAPA.EQ.4) WRITE (6,94) IF (IPAT.EQ.1.AND.MFP.NE.10) WRITE (6,70) IF (IPAT.EQ.2.AND.MFP.NE.10) WRITE (6,72) IF (IPAT.EQ.3.AND.MFP.NE.10) WRITE (6,74) IF (IPAT.EQ.1.AND.MFP.EQ.10.AND.IAPA.NE.4) WRITE (6,80) IF (IPAT.EQ.2.AND.MFP.EQ.10.AND.IAPA.NE.4) WRITE (6,82) IF (IPAT.EQ.3.AND.MFP.EQ.10.AND.IAPA.NE.4) WRITE (6,84) C READ DATA FOR WEIGHTED, DIFFERENCE FOURIER OR PATTERSON NUMB=0 115 READ (2) LH,LK,LL,EW,ED,RHO,RHO,RHO,RHO DO 120 I=1,600 IF (LH(I).LT.(-99)) GO TO 200 IF (SQRT(EW(I)*EW(I)+ED(I)*ED(I)).LT.0.001) GO TO 120 IF (RHO(I).GT.RHOLIM) GO TO 120 NUMB=NUMB+1 IF (NUMB.LE.KUSER1) GO TO 116 NN=NN+1 GO TO 120 116 ISC=1 IF (LH(I).LT.0) ISC=-1 IHKL(NUMB)=ISC*(LH(I)*262144+LK(I)*512+LL(I))+256*(512+1) MH(1)=MAX0(MH(1),IABS(LH(I))) MH(2)=MAX0(MH(2),IABS(LK(I))) MH(3)=MAX0(MH(3),IABS(LL(I))) E(NUMB)=EW(I) EP(NUMB)=FLOAT(ISC)*ED(I) IF (NUMB.EQ.KUSER1) GO TO 130 120 CONTINUE GO TO 115 130 WRITE (6,140) KUSER1 140 FORMAT(/1X,24X,5HFIRST,I6,19HREFLEXIONS ACCEPTED) GO TO 200 C EXAMINE SETS OF PHASES IN ORDER OF COMBINED FIGURE OF MERIT C UNLESS THE SET IS SPECIFIED BY THE USER 145 WRITE (6,50) IF (NOSET.GT.0) GO TO 170 150 READ (2) NIX IF (NIX .GE. 0) GO TO 150 READ (2) NSET, (CFOM(J), J=1,NSET) NPOS = 1 DO 160 J=1,NSET IF (CFOM(J) .GT. CFOM(NPOS)) NPOS = J 160 CONTINUE C MARK SELECTED SET CFOM(NPOS) = CFOM(NPOS)-100.0 BACKSPACE 2 WRITE (2) NSET, (CFOM(J), J=1,NSET) C READ TO FIND SELECTED SET 170 REWIND 2 READ (2) READ (2) NCS = 0 C EP WILL CONTAIN WEIGHTS 180 READ (2) NO, ABSFOM, PSIZRO, RESID, (J,EP(I), I=1,NUMB) NCS = NCS+1 IF (NOSET.EQ.0.AND.NCS.NE.NPOS) GO TO 180 IF (NOSET.NE.0.AND.NOSET.NE.NO) GO TO 180 NOSET = NO DO 185 I=1,NUMB E(I)=E(I)*EP(I) 185 CONTINUE BACKSPACE 2 READ (2) NO,ABSFOM,PSIZRO,RESID,(IPHAZ(I),WT,I=1,NUMB) WRITE (6,190) NO,ABSFOM,PSIZRO,RESID 190 FORMAT (10X,6HNUMSET,7X,7HABS FOM,11X,8HPSI ZERO,11X,5HRESID/ 1 7X,I8,F15.4,F17.2,F18.2) DO 192 I=1,NUMB PHASE=DTOR*FLOAT(IPHAZ(I)) EP(I)=E(I)*SIN(PHASE) E(I)=E(I)*COS(PHASE) 192 CONTINUE C SET DEFAULT VALUES OF PROGRAM PARAMETERS UNLESS SPECIFIED C BY USER AND CALCULATE NUMBER OF GRID POINTS FOR FOURIER MAP 200 IF (NN.GT.0) WRITE (6,118) NN 118 FORMAT(1X,' * * THE NUMBER OF REFLECTIONS IS OVER 10000 AND', 1 I4,1X,27HREFLEXIONS ARE REJECTED * *) 220 DO 280 I=1,3 NP(I)=PARA(I)/GRID+0.5 IF (I.EQ.3) NP(I)=NP(I)+MOD(NP(I),2) 250 NTEST=NP(I) DO 270 J=2,5 260 IF (NTEST.NE.(NTEST/J)*J) GO TO 270 NTEST=NTEST/J IF (NTEST.EQ.1) GO TO 280 GO TO 260 270 CONTINUE NP(I)=NP(I)+1 IF (I.EQ.3) NP(I)=NP(I)+1 GO TO 250 280 CONTINUE P1=NSIZE/(2.0*NP(2)*(MH(3)+1)) P2=NSIZE/(3.0*NP(1)*NP(3)) IF (P1.GE.1.0.AND.P2.GE.1.0.AND.NP(1).LE.300) GO TO 288 GRID=GRID+0.01 GO TO 220 288 WRITE (6,290) GRID 290 FORMAT(/1X,15X,30HGRID SPACING IS APPROXIMATELY ,F6.3,2X, 1 9HANGSTROMS) WRITE (6,300) PARA,MH,NP 300 FORMAT (/27X,1HA,8X,1HB,8X,1HC,6X,5HALPHA,4X,4HBETA,3X,5HGAMMA/ 1 1X,20HUNIT CELL PARAMETERS,3F9.3,1X,3F8.1//41X,1HH,9X,1HK,9X, 2 1HL/16X,16HMAXIMUM INDICES ,3I10//13X,21HNUMBER OF GRID POINTS, 3 6X,2HNX,8X,2HNY,8X,2HNZ/17X,15HIN FOURIER MAP ,3I10) IF (NP(1) .LE. 300) GO TO 400 WRITE (6,320) 320 FORMAT (/1X,'NX GREATER THAN 300.INCREASE ARRAY', 1 ' INPUT IN SUBROUTINE-OUTPUT OF FFT PROGRAM') CALL ERROR3 400 REWIND 1 WRITE (6,460) NUMB 460 FORMAT (//15X,41HNUMBER OF INDEPENDENT REFLECTIONS INPUT =, I7) C GENERATE ONE COMPLETE HEMISPHERE OF REFLEXIONS DO 470 I=1,15 TAB(I)=SIN(FLOAT(30*I)*DTOR) 470 CONTINUE NEX = 0 FSUM=0.0 IP5=256*(262144+512+1) NBATCH=0 DO 800 JN=1,NUMB I1(1)=IHKL(JN)/262144 J=IHKL(JN)-262144*I1(1) I1(2)=J/512-256 I1(3)=J-512*(I1(2)+256)-256 DO 700 J=1,NEQV DO 560 I=1,3 I2(I)=I1(1)*IS(I,1,J)+I1(2)*IS(I,2,J)+I1(3)*IS(I,3,J) 560 CONTINUE B1=1.0 JS=1 IF (I2(3)) 590,570,600 570 IF (I2(1)) 590,580,600 580 IF (I2(2)) 590,600,600 590 B1=-1.0 JS=-1 600 KIND(J)=IP5+JS*(262144*I2(1)+512*I2(2)+I2(3)) DO 610 I=1,3 IF (IABS(I2(I)).GE.NP(I)/2) GO TO 700 IF (I2(I).GT.MH(I)) MH(I)=I2(I) 610 CONTINUE IF (J.EQ.1) GO TO 630 ND=J-1 DO 620 I=1,ND IF (KIND(J).EQ.KIND(I)) GO TO 700 620 CONTINUE 630 NBATCH=NBATCH+1 NEX=NEX+1 NU=0 DO 640 I=1,3 SS(I,J)=TS(I,J) IF (IPAT.NE.0) SS(I,J)=0.0 640 NU=NU-I1(I)*INT(SS(I,J)*12.0+0.1) NU=MOD(NU,12) IF (NU.LE.0) NU=NU+12 XC=TAB(NU+3) XS=TAB(NU) GR=XC*E(JN)-XS*EP(JN) GI=(XS*E(JN)+XC*EP(JN))*B1 FSUM=FSUM+SQRT(GR*GR+GI*GI) G(1,NBATCH)=GR G(2,NBATCH)=GI IH(NBATCH)=KIND(J) IF (NBATCH.LT.100) GO TO 700 WRITE (1) IH,G NBATCH=0 700 CONTINUE 800 CONTINUE IF (NBATCH.NE.0) WRITE (1) IH,G SCALE=3000.0/FSUM WRITE (6,990) NEX,SCALE 990 FORMAT(/15X,41HNUMBER OF REFLECTIONS IN ONE HEMISPHERE =,I7/ 1 /1H ,25X,17HDENSITY SCALE =,F10.3) RETURN END C ------------------------------------------------------------------ SUBROUTINE CMPLFT (X, Y, NSIZE, N, D) REAL X(NSIZE), Y(NSIZE) INTEGER D(5),PMAX,PSYM,TWOGRP,FACTOR(15),SYM(15),UNSYM(15) C COMPLEX FINITE DISCRETE FOURIER TRANSFORM C TRANSFORMS ONE DIMENSION OF MULTI-DIMENSIONAL DATA C MODIFIED BY L. F. TEN EYCK FROM A ONE-DIMENSIONAL VERSION C WRITTEN BY G. T. SANDE, 1969. C THIS PROGRAM CALCULATES THE TRANSFORM C (X(T) + I*Y(T))*(COS(2*PI*T/N) - I*SIN(2*PI*T/N)) P MAX = 5 TWO GRP = 4 CALL S R FP (N, P MAX, TWO GRP, FACTOR, SYM, P SYM, UN SYM) CALL MDFTKD (N, FACTOR, D, X, Y, NSIZE) CALL DIPRP (N, SYM, P SYM, UN SYM, D, X, Y, NSIZE) RETURN END C ------------------------------------------------------------------ SUBROUTINE S R FP (PTS,PMAX,TWO GRP,FACTOR,SYM,P SYM,UN SYM) C SYMMETRIZED REORDERING FACTORING PROGRAM INTEGER PTS,PMAX,TWO GRP,P SYM,FACTOR (10), SYM (10), UN SYM (10) INTEGER PP(14), QQ (7), F,P,P TWO,Q,R NEST=14 N=PTS P SYM=1 F=2 P=0 Q=0 100 IF (N.LE.1) GO TO 500 DO 200 J=F,PMAX IF (N.EQ.(N/J)*J) GO TO 300 200 CONTINUE CALL ERROR3 300 F=J N=N/F IF (N.EQ.(N/F)*F) GO TO 400 Q=Q+1 QQ(Q)=F GO TO 100 400 N=N/F P=P+1 PP(P)=F P SYM=P SYM*F GO TO 100 500 R=1 IF (Q.EQ.0) R=0 IF (P.LT.1) GO TO 700 DO 600 J=1,P JJ=P+1-J SYM(J)=PP(JJ) FACTOR(J)=PP(JJ) JJ=P+Q+J FACTOR(JJ)=PP(J) JJ=P+R+J SYM(JJ)=PP(J) 600 CONTINUE 700 IF (Q.LT.1) GO TO 900 DO 800 J=1,Q JJ=P+J UN SYM(J)=QQ(J) FACTOR(JJ)=QQ(J) 800 CONTINUE SYM(P+1)=PTS/P SYM**2 900 JJ=2*P+Q FACTOR(JJ+1)=0 P TWO=1 J=0 1000 J=J+1 IF (FACTOR(J).EQ.0) GO TO 1200 IF (FACTOR(J).NE.2) GO TO 1000 P TWO=P TWO*2 FACTOR(J)=1 IF (P TWO.GE.TWO GRP) GO TO 1100 IF (FACTOR(J+1).EQ.2) GO TO 1000 1100 FACTOR(J)=P TWO P TWO=1 GO TO 1000 1200 IF (P.EQ.0) R=0 JJ=2*P+R SYM(JJ+1)=0 IF (Q.LE.1) Q=0 UN SYM(Q+1)=0 RETURN END C ------------------------------------------------------------------ SUBROUTINE DIPRP (PTS, SYM, P SYM, UN SYM, DIM, X, Y, NSIZE) C DOUBLE IN PLACE REORDERING PROGRAM REAL X(NSIZE), Y(NSIZE) INTEGER SYM(10), UN SYM(10), DIM(5), PTS, PSYM, DK,P UN SYM, TEST LOGICAL ONE MOD INTEGER SEP, DELTA, P, P0, P1, P2, P3, P4, P5, SIZE INTEGER V(14), MODULO(14), S(14), U(14) NEST=14 NT = DIM(1) SEP = DIM(2) P2 = DIM(3) SIZE = DIM(4) - 1 P4 = DIM(5) IF (SYM(1).EQ.0) GO TO 500 DO 100 J=1,NEST U(J)=1 S(J)=1 100 CONTINUE N=PTS DO 200 J=1,NEST IF (SYM(J).EQ.0) GO TO 300 JJ=NEST+1-J U(JJ)=N N=N/SYM(J) S(JJ)=N 200 CONTINUE 300 JJ=0 L=1 V(1)=1 310 L=L+1 V(L)=V(L-1) 320 IF (L.LT.NEST) GO TO 310 N=V(NEST) JJ=JJ+1 IF (JJ.GE.N) GO TO 400 DELTA = (N-JJ)*SEP P1 = (JJ-1)*SEP + 1 DO 350 P0 = P1, NT, P2 P3 = P0 + SIZE DO 350 P = P0, P3, P4 P5 = P + DELTA T = X(P) X(P) = X(P5) X(P5) = T T = Y(P) Y(P) = Y(P5) Y(P5) = T 350 CONTINUE 400 V(L)=V(L)+S(L) IF (V(L).LE.U(L)) GO TO 320 L=L-1 IF (L.NE.0) GO TO 400 500 IF (UN SYM(1).EQ.0) GO TO 1900 P UN SYM=PTS/P SYM**2 MULT=P UN SYM/UN SYM(1) TEST=(UN SYM(1)*UN SYM(2)-1)*MULT*P SYM LK=MULT DK=MULT DO 600 K=2,NEST IF (UN SYM(K).EQ.0) GO TO 700 LK=LK*UN SYM(K-1) DK=DK/UN SYM(K) U(K)=(LK-DK)*P SYM MODS=K 600 CONTINUE 700 ONE MOD=MODS.LT.3 IF (ONE MOD) GO TO 900 DO 800 J=3,MODS JJ=MODS+3-J MODULO(JJ)=U(J) 800 CONTINUE 900 MODULO(2)=U(2) JL=(P UN SYM-3)*P SYM MS=P UN SYM*P SYM DO 1800 J=P SYM,JL,P SYM K=J 1000 K=K*MULT IF (ONE MOD) GO TO 1200 DO 1100 I=3,MODS K=K-(K/MODULO(I))*MODULO(I) 1100 CONTINUE 1200 IF (K.GE.TEST) GO TO 1300 K=K-(K/MODULO(2))*MODULO(2) GO TO 1400 1300 K=K-(K/MODULO(2))*MODULO(2)+MODULO(2) 1400 IF (K.LT.J) GO TO 1000 IF (K.EQ.J) GO TO 1800 DELTA = (K-J)*SEP DO 1600 L=1,P SYM DO 1500 M=L,PTS,MS P1 = (M+J-1)*SEP + 1 DO 1500 P0 = P1, NT, P2 P3 = P0 + SIZE DO 1500 JJ = P0, P3, P4 KK = JJ + DELTA T=X(JJ) X(JJ)=X(KK) X(KK)=T T=Y(JJ) Y(JJ)=Y(KK) Y(KK)=T 1500 CONTINUE 1600 CONTINUE 1800 CONTINUE 1900 RETURN END C ------------------------------------------------------------------ SUBROUTINE MDFTKD (N, FACTOR, DIM, X, Y, NSIZE) C MULTI-DIMENSIONAL COMPLEX FOURIER TRANSFORM KERNEL DRIVER REAL X(NSIZE), Y(NSIZE) INTEGER FACTOR(10), DIM(5), F, P, R, S S = DIM(2) F = 0 M = N 100 F = F + 1 P = FACTOR(F) IF (P.EQ.0) RETURN M = M/P R = M*S GO TO (100, 200, 300, 400, 500), P 200 CALL R2 CFTK (N, M, X, Y, NSIZE, R, DIM) GO TO 100 300 CALL R3 CFTK (N, M, X, Y, NSIZE, R, DIM) GO TO 100 400 CALL R4 CFTK (N, M, X, Y, NSIZE, R, DIM) GO TO 100 500 CALL R5 CFTK (N, M, X, Y, NSIZE, R, DIM) GO TO 100 END C ------------------------------------------------------------------ SUBROUTINE R2 CFTK (N, M, X, Y, NSIZE, R, DIM) C RADIX 2 MULTI-DIMENSIONAL COMPLEX FOURIER TRANSFORM KERNEL REAL X(NSIZE), Y(NSIZE) REAL IS, IU INTEGER DIM(5), SIZE, SEP, R LOGICAL FOLD,ZERO COMMON /PERIF/ TWOPI NT = DIM(1) SEP = DIM(2) L1 = DIM(3) SIZE = DIM(4) - 1 K2 = DIM(5) NS = N*SEP M2=M*2 FM2 = FLOAT(M2) M OVER 2=M/2+1 MM2 = SEP*M2 FJM1 = -1.0 DO 600 J=1,M OVER 2 FOLD=J.GT.1 .AND. 2*J.LT.M+2 K0 = (J-1)*SEP + 1 FJM1 = FJM1 + 1.0 ANGLE = TWOPI*FJM1/FM2 ZERO=ANGLE.EQ.0.0 IF (ZERO) GO TO 200 C=COS(ANGLE) S=SIN(ANGLE) GO TO 200 100 FOLD=.FALSE. K0 = (M+1-J)*SEP + 1 C=-C 200 DO 500 KK = K0, NS, MM2 DO 440 L = KK, NT, L1 K1 = L + SIZE DO 420 K = L, K1, K2 RS=X(K)+X(K+R) IS=Y(K)+Y(K+R) RU=X(K)-X(K+R) IU=Y(K)-Y(K+R) X(K)=RS Y(K)=IS IF (ZERO) GO TO 300 X(K+R)=RU*C+IU*S Y(K+R)=IU*C-RU*S GO TO 420 300 X(K+R)=RU Y(K+R)=IU 420 CONTINUE 440 CONTINUE 500 CONTINUE IF (FOLD) GO TO 100 600 CONTINUE RETURN END C ------------------------------------------------------------------ SUBROUTINE R3 CFTK (N, M, X, Y, NSIZE, R, DIM) C RADIX 3 MULTI-DIMENSIONAL COMPLEX FOURIER TRANSFORM KERNEL REAL X(NSIZE), Y(NSIZE) REAL I0,I1,I2,IA,IB,IS INTEGER DIM(5), SIZE, SEP ,R LOGICAL FOLD,ZERO COMMON /PERIF/ TWOPI DATA A/-0.5/, B/0.86602540/ NT = DIM(1) SEP = DIM(2) L1 = DIM(3) SIZE = DIM(4) - 1 K2 = DIM(5) NS = N*SEP M3=M*3 FM3 = FLOAT(M3) MM3 = SEP*M3 M OVER 2=M/2+1 FJM1 = -1.0 DO 600 J=1,M OVER 2 FOLD=J.GT.1 .AND. 2*J.LT.M+2 K0 = (J-1)*SEP + 1 FJM1 = FJM1 + 1.0 ANGLE = TWOPI*FJM1/FM3 ZERO=ANGLE.EQ.0.0 IF (ZERO) GO TO 200 C1=COS(ANGLE) S1=SIN(ANGLE) C2=C1*C1-S1*S1 S2=S1*C1+C1*S1 GO TO 200 100 FOLD=.FALSE. K0 = (M+1-J)*SEP + 1 T=C1*A+S1*B S1=C1*B-S1*A C1=T T=C2*A-S2*B S2=-C2*B-S2*A C2=T 200 DO 500 KK = K0, NS, MM3 DO 440 L = KK, NT, L1 K1 = L + SIZE DO 420 K = L, K1, K2 R0=X(K) I0=Y(K) RS=X(K+R)+X(K+2*R) IS=Y(K+R)+Y(K+2*R) X(K)=R0+RS Y(K)=I0+IS RA=R0+RS*A IA=I0+IS*A RB=(X(K+R)-X(K+2*R))*B IB=(Y(K+R)-Y(K+2*R))*B IF (ZERO) GO TO 300 R1=RA+IB I1=IA-RB R2=RA-IB I2=IA+RB X(K+R)=R1*C1+I1*S1 Y(K+R)=I1*C1-R1*S1 X(K+2*R)=R2*C2+I2*S2 Y(K+2*R)=I2*C2-R2*S2 GO TO 420 300 X(K+R)=RA+IB Y(K+R)=IA-RB X(K+2*R)=RA-IB Y(K+2*R)=IA+RB 420 CONTINUE 440 CONTINUE 500 CONTINUE IF (FOLD) GO TO 100 600 CONTINUE RETURN END C ------------------------------------------------------------------ SUBROUTINE R4 CFTK (N, M, X, Y, NSIZE, R, DIM) C RADIX 4 MULTI-DIMENSIONAL COMPLEX FOURIER TRANSFORM KERNEL REAL X(NSIZE), Y(NSIZE) INTEGER DIM(5), SIZE, SEP, R LOGICAL FOLD,ZERO REAL I1,I2,I3,IS0,IS1,IU0,IU1 COMMON /PERIF/ TWOPI NT = DIM(1) SEP = DIM(2) L1 = DIM(3) SIZE = DIM(4) - 1 K2 = DIM(5) NS = N*SEP M4=M*4 FM4 = FLOAT(M4) MM4 = SEP*M4 M OVER 2=M/2+1 FJM1 = -1.0 DO 600 J=1,M OVER 2 FOLD=J.GT.1 .AND. 2*J.LT.M+2 K0 = (J-1)*SEP + 1 FJM1 = FJM1 + 1.0 ANGLE = TWOPI*FJM1/FM4 ZERO=ANGLE.EQ.0.0 IF (ZERO) GO TO 200 C1=COS(ANGLE) S1=SIN(ANGLE) C2=C1*C1-S1*S1 S2=S1*C1+C1*S1 C3=C2*C1-S2*S1 S3=S2*C1+C2*S1 GO TO 200 100 FOLD=.FALSE. K0 = (M+1-J)*SEP + 1 T=C1 C1=S1 S1=T C2=-C2 T=C3 C3=-S3 S3=-T 200 DO 500 KK = K0, NS, MM4 DO 440 L = KK, NT, L1 K1 = L + SIZE DO 420 K = L, K1, K2 RS0=X(K)+X(K+2*R) IS0=Y(K)+Y(K+2*R) RU0=X(K)-X(K+2*R) IU0=Y(K)-Y(K+2*R) RS1=X(K+R)+X(K+3*R) IS1=Y(K+R)+Y(K+3*R) RU1=X(K+R)-X(K+3*R) IU1=Y(K+R)-Y(K+3*R) X(K)=RS0+RS1 Y(K)=IS0+IS1 IF (ZERO) GO TO 300 R1=RU0+IU1 I1=IU0-RU1 R2=RS0-RS1 I2=IS0-IS1 R3=RU0-IU1 I3=IU0+RU1 X(K+2*R)=R1*C1+I1*S1 Y(K+2*R)=I1*C1-R1*S1 X(K+R)=R2*C2+I2*S2 Y(K+R)=I2*C2-R2*S2 X(K+3*R)=R3*C3+I3*S3 Y(K+3*R)=I3*C3-R3*S3 GO TO 420 300 X(K+2*R)=RU0+IU1 Y(K+2*R)=IU0-RU1 X(K+R)=RS0-RS1 Y(K+R)=IS0-IS1 X(K+3*R)=RU0-IU1 Y(K+3*R)=IU0+RU1 420 CONTINUE 440 CONTINUE 500 CONTINUE IF (FOLD) GO TO 100 600 CONTINUE RETURN END C ------------------------------------------------------------------ SUBROUTINE R5 CFTK(N, M, X, Y, NSIZE, R, DIM) C RADIX 5 MULTI-DIMENSIONAL COMPLEX FOURIER TRANSFORM KERNEL REAL X(NSIZE), Y(NSIZE) REAL I0,I1,I2,I3,I4,IA1,IA2,IB1,IB2,IS1,IS2,IU1,IU2 INTEGER DIM(5), SIZE, SEP, R LOGICAL FOLD,ZERO COMMON /PERIF/ TWOPI DATA A1/0.30901699/,B1/0.95105652/,A2/-0.80901699/,B2/0.58778525/ NT = DIM(1) SEP = DIM(2) L1 = DIM(3) SIZE = DIM(4) - 1 K2 = DIM(5) NS = N*SEP M5=M*5 FM5 = FLOAT(M5) MM5 = SEP*M5 M OVER 2=M/2+1 FJM1 = -1.0 DO 600 J=1,M OVER 2 FOLD=J.GT.1 .AND. 2*J.LT.M+2 K0 = (J-1)*SEP + 1 FJM1 = FJM1 + 1.0 ANGLE = TWOPI*FJM1/FM5 ZERO=ANGLE.EQ.0.0 IF (ZERO) GO TO 200 C1=COS(ANGLE) S1=SIN(ANGLE) C2=C1*C1-S1*S1 S2=S1*C1+C1*S1 C3=C2*C1-S2*S1 S3=S2*C1+C2*S1 C4=C2*C2-S2*S2 S4=S2*C2+C2*S2 GO TO 200 100 FOLD=.FALSE. K0 = (M+1-J)*SEP + 1 T=C1*A1+S1*B1 S1=C1*B1-S1*A1 C1=T T=C2*A2+S2*B2 S2=C2*B2-S2*A2 C2=T T=C3*A2-S3*B2 S3=-C3*B2-S3*A2 C3=T T=C4*A1-S4*B1 S4=-C4*B1-S4*A1 C4=T 200 DO 500 KK = K0, NS, MM5 DO 440 L = KK, NT, L1 K1 = L + SIZE DO 420 K = L, K1, K2 R0=X(K) I0=Y(K) RS1=X(K+R)+X(K+4*R) IS1=Y(K+R)+Y(K+4*R) RU1=X(K+R)-X(K+4*R) IU1=Y(K+R)-Y(K+4*R) RS2=X(K+2*R)+X(K+3*R) IS2=Y(K+2*R)+Y(K+3*R) RU2=X(K+2*R)-X(K+3*R) IU2=Y(K+2*R)-Y(K+3*R) X(K)=R0+RS1+RS2 Y(K)=I0+IS1+IS2 RA1=R0+RS1*A1+RS2*A2 IA1=I0+IS1*A1+IS2*A2 RA2=R0+RS1*A2+RS2*A1 IA2=I0+IS1*A2+IS2*A1 RB1=RU1*B1+RU2*B2 IB1=IU1*B1+IU2*B2 RB2=RU1*B2-RU2*B1 IB2=IU1*B2-IU2*B1 IF (ZERO) GO TO 300 R1=RA1+IB1 I1=IA1-RB1 R2=RA2+IB2 I2=IA2-RB2 R3=RA2-IB2 I3=IA2+RB2 R4=RA1-IB1 I4=IA1+RB1 X(K+R)=R1*C1+I1*S1 Y(K+R)=I1*C1-R1*S1 X(K+2*R)=R2*C2+I2*S2 Y(K+2*R)=I2*C2-R2*S2 X(K+3*R)=R3*C3+I3*S3 Y(K+3*R)=I3*C3-R3*S3 X(K+4*R)=R4*C4+I4*S4 Y(K+4*R)=I4*C4-R4*S4 GO TO 420 300 X(K+R)=RA1+IB1 Y(K+R)=IA1-RB1 X(K+2*R)=RA2+IB2 Y(K+2*R)=IA2-RB2 X(K+3*R)=RA2-IB2 Y(K+3*R)=IA2+RB2 X(K+4*R)=RA1-IB1 Y(K+4*R)=IA1+RB1 420 CONTINUE 440 CONTINUE 500 CONTINUE IF (FOLD) GO TO 100 600 CONTINUE RETURN END C ------------------------------------------------------------------ SUBROUTINE HERMFT (X, Y, NSIZE, N, DIM) REAL X(NSIZE), Y(NSIZE) INTEGER DIM(5), D2, D3, D4, D5 C HERMITIAN SYMMETRIC FOURIER TRANSFORM COMMON /PERIF/ TWOPI TWO N = FLOAT(2*N) NT = DIM(1) D2 = DIM(2) D3 = DIM(3) D4 = DIM(4) - 1 D5 = DIM(5) DO 100 I0 = 1, NT, D3 I1 = I0 + D4 DO 100 I = I0, I1, D5 A = X(I) B = Y(I) X(I) = A + B Y(I) = A - B 100 CONTINUE N OVER 2 = N/2 + 1 IF (N OVER 2 .LT. 2) GO TO 500 DO 400 I0 = 2, N OVER 2 ANGLE = TWOPI*FLOAT(I0-1)/TWO N CO = COS(ANGLE) SI = SIN(ANGLE) K = (N + 2 - 2*I0)*D2 K1 = (I0 - 1)*D2 + 1 DO 300 I1 = K1, NT, D3 I2 = I1 + D4 DO 200 I = I1, I2, D5 J = I + K A = X(I) + X(J) B = X(I) - X(J) C = Y(I) + Y(J) D = Y(I) - Y(J) E = B*CO + C*SI F = B*SI - C*CO X(I) = A + F X(J) = A - F Y(I) = E + D Y(J) = E - D 200 CONTINUE 300 CONTINUE 400 CONTINUE CALL CMPLFT (X, Y, NSIZE, N, DIM) 500 RETURN END C ------------------------------------------------------------------ SUBROUTINE PP1 (X, NSIZE, NX, NY, NZ) REAL X(NSIZE) INTEGER P1, P2, R, SKIP, RECS, D(5) COMMON /PERIF/ TWOPI,VECT(8,3),MFP COMMON /TRAN/ SCALE,ITLE(80),MH(3) COMMON /TRANN/ TL(3,4),TS(3,24),FS(216),NDIFF,MN,NALIM,N,NPC COMMON /TAPE/ NOSET,PARA(6),NEQV,NCENT,LATT,NATM,IS(3,3,24) CHARACTER ITLE XMAX=-1000.0 XMIN=1000.0 P1 = NSIZE/(2*NY*(MH(3) + 1)) P2 = NSIZE/(NX*NZ) IF (P1 .LT. 1 .OR. P2 .LT. 1) GO TO 300 C PASS ONE. TRANSFORM ON K AND WRITE INTERMEDIATE RESULTS ON CH.-8 REWIND 8 R = -MH(1) 100 IF (R + P1 .GT. MH(1)) P1 = MH(1) + 1 - R CALL READ KL(X, NY, MH(3)+1, P1, R) D(1) = 2*(NY*P1*(MH(3)+1)) D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = 2*NY CALL CMPLFT (X(1), X(2), NSIZE, NY, D) CALL WRITE Y (X, NY, MH(3)+1, P1, P2) R = R + P1 IF (R .LE. MH(1)) GO TO 100 C END OF PASS 1. PASS 2 READS BACK THE INTERMEDIATE RESULTS, C CALCULATES THE TRANSFORMS ON H AND L, AND WRITES OUT C THE FINAL Y SECTIONS. REWIND 1 WRITE (1) ITLE,NOSET,PARA,NEQV,NCENT,LATT,NATM,TS,IS WRITE (1) NX,NZ,NY REWIND 8 SKIP = 0 R = 0 P1 = NSIZE/(2*NY*(MH(3) + 1)) RECS = (NY - 1)/P2 200 IF (R + P2 .GT. NY) P2 = NY - R CALL READ HL (X, NX, NZ/2, P2, MH(1), MH(3), P1, SKIP, RECS) IF (R + P2 .LT. NY) REWIND 8 SKIP = SKIP + 1 C X NOW CONTAINS INTERMEDIATE RESULTS STORED WITH L DOWN C THE COLUMNS AND H ACROSS THE ROWS. D(1) = NX*NZ*P2 D(2) = NZ D(3) = NZ*NX D(4) = 2*(MH(3) + 1) D(5) = 2 CALL CMPLFT (X(1), X(2), NSIZE, NX, D) D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NZ CALL HERMFT (X(1), X(2), NSIZE, NZ/2, D) CALL OUTPUT3 (X, NZ, NX, P2, R) R = R + P2 IF (R .LT. NY) GO TO 200 C END OF JOB RETURN 300 P1 = 2*NY*(MH(3)+1) P2 = NX * NZ WRITE (6,350) NSIZE, P1, P2 350 FORMAT(/1X,15X,37HREQUEST TOO LARGE. SPACE AVAILABLE IS,I10/ 1 1X,15X,33H AND SPACE REQUESTED IS LARGER OF,I10,4H AND,I10) CALL ERROR3 RETURN END C ------------------------------------------------------------------ SUBROUTINE READ KL(X, NY, NZ, NX, HS) INTEGER HS, H, HM, HL COMPLEX X(NY,NZ,NX) COMMON /REFL/ IH(100), G(2,100) COMMON /CONST/ NEX REWIND 1 NBLOCK = NEX/100+1 HM=262144*(HS+NX-1+256)+(512+1)*(2*256-1) HL=262144*(HS+256) DO 100 H = 1, NX DO 100 L = 1, NZ DO 100 K = 1, NY X(K,L,H) = CMPLX(0.0,0.0) 100 CONTINUE M=100 DO 500 IB=1,NBLOCK IF (IB.EQ.NBLOCK) M=MOD(NEX,100) IF (M.EQ.0) GO TO 500 READ (1) IH,G DO 300 J = 1, M IHJ=IH(J) IF (IHJ.GT.HM.OR.IHJ.LT.HL) GO TO 300 H=IHJ/262144-256 L=IHJ-262144*(H+256) K=L/512-256 L=L-512*(K+256)-256 NOKO = 0 IF (H.EQ.0.AND.L.EQ.0.AND.K.NE.0) NOKO = NY-K+1 H = H - HS + 1 IF (K.LT.0)K=NY+K K = K + 1 L = L + 1 X(K,L,H) = CMPLX(G(1,J),G(2,J)) IF (NOKO.NE.0) X(NOKO,L,H) = CONJG(X(K,L,H)) 300 CONTINUE 500 CONTINUE RETURN END C ------------------------------------------------------------------ SUBROUTINE WRITE Y (X, NY, NZ, NX, SIZE) INTEGER SIZE, H, P, Q, R COMPLEX X(NY,NZ,NX) P = SIZE Q = 0 100 R = Q + 1 IF (Q + P .GT. NY) P = NY - Q Q = Q + P WRITE (8) (((X(K,L,H), H = 1, NX), K = R, Q), L = 1, NZ) IF (Q .LT. NY) GO TO 100 RETURN END C ------------------------------------------------------------------ SUBROUTINE READ HL (X, NX, NZ, NY, HMAX, LMAX, SIZE, SKIP, RECS) INTEGER HMAX, SIZE, SKIP ,RECS, H, HL, HU, P, Q COMPLEX X(NZ,NX,NY) C READS IN INTERMEDIATE RESULTS FOR ALL H AND L FOR A BLOCK OF K. C THE INPUT IS STORED WITH L DOWN THE COLUMNS AND H ON THE ROWS. LM = LMAX + 1 P = SIZE HU = NX - HMAX IF (SKIP .LE. 0) GO TO 200 DO 100 Q = 1, SKIP READ (8) 100 CONTINUE C READ DATA FOR NEGATIVE H 200 IF (HU + P .GT. NX) GO TO 400 HL = HU + 1 HU = HU + P READ (8) (((X(L,H,K), H = HL, HU), K = 1, NY), L = 1, LM) IF (RECS .LE. 0) GO TO 200 DO 300 Q = 1, RECS READ (8) 300 CONTINUE GO TO 200 C GO PICK UP RECORD WHICH SPANS H = 0 IF NECESSARY 400 IF (HU .NE. NX) GO TO 700 HU = 0 C READ RECORDS FOR POSITIVE H 500 IF (HU + P .GT. HMAX + 1) P = HMAX + 1 - HU HL = HU + 1 HU = HU + P READ (8) (((X(L,H,K), H = HL, HU), K = 1, NY), L = 1, LM) 550 IF (HU .EQ. HMAX + 1) GO TO 800 IF (RECS .LE. 0) GO TO 500 DO 600 Q = 1, RECS READ (8) 600 CONTINUE GO TO 500 C SECTION TO READ A RECORD SPANNING H = 0 700 HL = HU + 1 HU = HU + P - NX IF (HU .GT. HMAX + 1) HU = HMAX + 1 READ (8) (((X(L,H,K), H = HL, NX), (X(L,H,K), H = 1, HU), 1 K = 1, NY), L = 1, LM) GO TO 550 C PAD THE ARRAY WITH ZERO WHERE THERE ARE NO DATA, AND FILL IN THE C -H K 0 RESULTS BY SYMMETRY. 800 DO 900 H = 2, HU HL = NX + 2 - H DO 900 K = 1, NY X(1,HL,K) = CONJG(X(1,H,K)) 900 CONTINUE HL = HMAX + 2 HU = NX - HMAX IF (HU .LT. HL) GO TO 920 DO 910 L = 1, LM DO 910 K = 1, NY DO 910 H = HL, HU X(L,H,K) = CMPLX(0.0,0.0) 910 CONTINUE 920 IF (LM .GE. NZ) GO TO 940 P = LM + 1 DO 930 K = 1, NY DO 930 L = P, NZ DO 930 H = 1, NX X(L,H,K) = CMPLX(0.0,0.0) 930 CONTINUE C END OF INPUT 940 RETURN END C ------------------------------------------------------------------ SUBROUTINE OUTPUT3 (X, NZ, NX, NY, Y) REAL X(NZ,NX,NY) INTEGER Y DIMENSION INPUT(300) COMMON /PERIF/ TWOPI,VECT(8,3),MFP COMMON /TRAN/ SCALE,ITLE(80),MH(3) CHARACTER ITLE DO 250 K=1,NY DO 50 J=1,NZ DO 30 I=1,NX X1=X(J,I,K)*SCALE X(J,I,K)=X1 INPUT(I)=0 IF (X1.NE.0.0) INPUT(I)=X1+SIGN(0.5,X1) 30 CONTINUE WRITE (1) (INPUT(I), I=1,NX) 50 CONTINUE 250 CONTINUE RETURN END ************************************************************************ * * * M M IIIII N N FFFFFFF N N * * MM MM I NN N F NN N * * M M M M I N N N F N N N * * M M M I N N N FFFFF N N N * * M M I N N N F N N N * * M M I N NN F N NN * * M M IIIII N N F N N * * * * PROGRAM FOR CALCULATING PATTERSON SUPERPOSITION FUNCTIONS * * (MINIMUM AND SUM FUNCTIONS) * * VERSION 1996 * ************************************************************************ SUBROUTINE MINFN (LX,MX,KX,NX,NY,NZ) COMMON /PERIF/ TWOPI,VECR(8,3),MFP,IPAT,XMAX,XMIN COMMON /CONST/ NEX,KUSER1,DTOR,NP(3) COMMON /TRANN/ TL(3,4),TS(3,24),FS(216),NDIFF,MN,NALIM,MLAT,NPC COMMON /TAPE/ NOSET,PARA(6),NEQV,NCENT,LATT,NATM,IS(3,3,24) DIMENSION MX(NX,NZ),S(3),NPT1(3),SPT1(3),SS(3),VECT(48,3) DIMENSION KX(NX,NZ),LX(NX,NZ),X1(196),Y1(196),Z1(196) C MFP=1 OR 3 IN P-E MIN./SUM. CASE C MFP=2 OR 4 IN P-P MIN./SUM. CASE XMAX=-1000.0 XMIN=10000.0 MMM=MLAT MLAT=1 NUMB=0 DO 170 II=1,MN CALL EQPO(VECR(II,1),VECR(II,2),VECR(II,3),X1,Y1,Z1,NEQ,1) DO 150 J=1,NEQ IF (NUMB.EQ.48) THEN WRITE (6,1450) GO TO 180 ENDIF C IT WILL INCLUDE ALL ATOM'S X Y Z DEPENDING ON THE SPACE GROUP'S C SYMMETRY WITHOUT LATTICE CENTER NUMB=NUMB+1 VECT(NUMB,1)=X1(J) VECT(NUMB,2)=Y1(J) VECT(NUMB,3)=Z1(J) 150 CONTINUE 170 CONTINUE 180 MLAT=MMM IF (MOD(MFP,2).EQ.0) THEN WRITE (6,1600) C IN P-P MIN./SUM. FUNCTION CASE, TO COPY ONE MORE PATTERSON MAP C AS THE 'EMAP.IN' FILE CONNECTING THE UNIT-4 FOR A USE LATER. CALL CCPDPN(4,'SCRA4.TM','SCRATCH','U',80,0) c OPEN(4,FILE='SCRA4.TM',FORM='UNFORMATTED',STATUS='UNKNOWN') NSTART=2 REWIND 1 DO 190 I=1,2 READ (1) WRITE (4) 190 CONTINUE DO 200 IY=1,NY DO 200 IZ=1,NZ READ (1) (LX(IX,IZ),IX=1,NX) WRITE (4) (LX(IX,IZ),IX=1,NX) 200 CONTINUE ELSE WRITE (6,1500) C IN P-E MIN./SUM. FUNCTION CASE, THE E-MAP TO BE USED AS THE C 'EMAP.IN' FILE CONNECTING THE UNIT-4 FOR A USE LATER. CALL CCPDPN(4,'EMAPIN','UNKNOWN','U',80,0) c OPEN(4,FILE='EMAP.IN',FORM='UNFORMATTED',STATUS='UNKNOWN') NSTART=1 ENDIF CALL CCPDPN(3,'SCRA3.TM','SCRATCH','DU',NX*4,0) c OPEN(3,FILE='SCRA3.TM',RECL=NX*4,ACCESS='DIRECT', c 1 FORM='UNFORMATTED',STATUS='UNKNOWN') IJ=0 DO 900 NPP=NSTART,NUMB IJ=IJ+1 DO 300 I=1,3 SS(I)=AMOD(VECT(NPP,I)+10.0,1.0) IF (MOD(MFP,2).EQ.0) SS(I)=AMOD(VECT(1,I)-VECT(NPP,I)+5.0,1.0) S(I)=SS(I)*NP(I) IF (MOD(MFP,2).EQ.1) S(I)=AMOD((5.0-SS(I)),1.0)*NP(I) C NOTE: NPT1 MAY INCLUDE ATOM'S POSITION AT 0,AND/OR 0,AND/OR 0 NPT1(I)=INT(S(I)) SPT1(I)=FLOAT((NPT1(I)+1))-S(I) 300 CONTINUE WRITE (6,1700) IJ,(SS(I),I=1,3) REWIND 4 REWIND 1 DO 310 I=1,2 READ (1) READ (4) 310 CONTINUE IF (NPT1(2).EQ.0) GO TO 400 C Y-TRANSLATION TO THE WHOLE PATTERSON MAP IYY=NPT1(2) DO 350 I=1,IYY DO 350 J=1,NZ READ (1) 350 CONTINUE 400 IST=NPT1(2) ISECT=1 IFLAG=1 DO 800 IY=1,NY C TO READ MAPS AND COMPLETE LINEAR INTRAPOLATION CALL PMREAD(LX,MX,KX,NX,NY,NZ,IST,ISECT,IFLAG,NPT1,SPT1) C MIN./SUM. FUNCTION IS GOING ON AS FOLLOWING DO 550 IZ=1,NZ READ (4) (MX(IX,IZ),IX=1,NX) DO 500 IX=1,NX cc IF (MOD(MFP,2).EQ.1) GO TO 450 C IN P-P CASE: c IF (MFP.EQ.2) LX(IX,IZ)=MIN0(LX(IX,IZ),MX(IX,IZ)) c IF (MFP.EQ.4) LX(IX,IZ)=LX(IX,IZ)+MX(IX,IZ) IF (MFP.LE.2) LX(IX,IZ)=MIN0(LX(IX,IZ),MX(IX,IZ)) IF (MFP.GE.3) LX(IX,IZ)=LX(IX,IZ)+MX(IX,IZ) cc GO TO 500 C IN P-E CASE: NALIM IS A CUTOFF VALUE ON PATTERSON MAP C NALIM=ZJMAX*ZJMIN/4 CALCULATED BY PROGRAM--PREPARE cc450 IF (LX(IX,IZ).LE.NALIM) LX(IX,IZ)=0 cc IF (LX(IX,IZ).GT.NALIM) LX(IX,IZ)=MX(IX,IZ) 500 CONTINUE 550 CONTINUE IF (IJ.EQ.1) GO TO 650 C GO ON MIN./SUM. FUNCTION AGAIN WITH ANOTHER MIN./SUM. MAP C WHICH WAS CALCULATED AT THE LAST TIME WITH OTHER ATOM(S) C STARTING FROM THE SECOND ATOM PUT ON THE DIMENSION VECT(*,*). DO 600 IZ=1,NZ KY=(IY-1)*NZ+IZ 600 READ (3,REC=KY) (MX(IX,IZ),IX=1,NX) DO 620 IZ=1,NZ DO 620 IX=1,NX IF (MFP.LE.2) LX(IX,IZ)=MIN0(LX(IX,IZ),MX(IX,IZ)) IF (MFP.GE.3) LX(IX,IZ)=LX(IX,IZ)+MX(IX,IZ) 620 CONTINUE C IN THE CASE WHEN THE FIRST ATOM IS USED FOR MIN./SUM.- FUN. 650 DO 700 IZ=1,NZ KY=(IY-1)*NZ+IZ 700 WRITE (3,REC=KY) (LX(IX,IZ),IX=1,NX) 800 CONTINUE 900 CONTINUE C MOD(MFP,2).EQ.1 MEANS: IT IS FOR P-E MIN./SUM. FUNCTION CASE IF (MOD(MFP,2).EQ.1) GO TO 1200 REWIND 1 READ (1) READ (1) DO 1000 I=1,3 S(I)=AMOD((VECT(1,I)+5.0),1.0)*NP(I) S(I)=FLOAT(NP(I))-S(I) NPT1(I)=INT(S(I)) SPT1(I)=FLOAT((NPT1(I)+1))-S(I) 1000 CONTINUE IST=NPT1(2) ISECT=1 IFLAG=3 DO 1100 IY=1,NY CALL PMREAD(LX,MX,KX,NX,NY,NZ,IST,ISECT,IFLAG,NPT1,SPT1) 1100 CONTINUE GO TO 1400 1200 REWIND 1 READ (1) READ (1) DO 1350 IY=1,NY DO 1220 IZ=1,NZ KY=(IY-1)*NZ+IZ 1220 READ (3,REC=KY) (LX(IX,IZ),IX=1,NX) DO 1250 IZ=1,NZ DO 1240 IX=1,NX XMAX=AMAX1(FLOAT(LX(IX,IZ)),XMAX) XMIN=AMIN1(FLOAT(LX(IX,IZ)),XMIN) 1240 CONTINUE WRITE (1) (LX(IX,IZ),IX=1,NX) 1250 CONTINUE 1350 CONTINUE 1400 IF (MFP.LE.2) WRITE (6,1800) XMAX,XMIN IF (MFP.GT.2) WRITE (6,2000) XMAX,XMIN 1450 FORMAT(//18X,'THE NUMBER OF TRANSLATION VECTORS > 48') 1500 FORMAT(/24X,'ATOMIC SITES FOR SUPERPOSITION', 1 //20X,'PEAK X Y Z ') 1600 FORMAT(/15X,'HARKER PEAKS OR (+NON-HARKER) FOR SUPERPOSITION', 1 //20X,'PEAK U V W ') 1700 FORMAT(21X,I2,1X,3(F9.4,3X)) 1800 FORMAT(/14X,31HTHE MINIMUM FUNCTION WITH MAX.=,F7.1,6H MIN.=,F7.1) 2000 FORMAT(/16X,27HTHE SUM FUNCTION WITH MAX.=,F7.1,6H MIN.=,F7.1) CLOSE (UNIT=4) CLOSE (UNIT=3) RETURN END C ------------------------------------------------------------------ C TO READ MAPS AND COMPLETE LINEAR INTRAPOLATION ON A SECTION FIRST C AND THEN SECOND BETWEEN TWO SECTIONS IN A 3D-MAP SUBROUTINE PMREAD (LX,MX,KX,NX,NY,NZ,IST,ISECT,IFLAG,NPT1,SPT1) COMMON /PERIF/ TWOPI,VECR(8,3),MFP,IPAT,XMAX,XMIN DIMENSION MX(NX,NZ),KX(NX,NZ),LX(NX,NZ),NPT1(3),SPT1(3) 100 IST=IST+1 C READ A SECTION (REALLY READ FROM IY=IYY+1 TO IY=IYY+NY+1) C FROM THE P-MAP FOR THE Y-TRANSLATION TO A 3D-MAP IF (IFLAG.EQ.3.AND.IST.GT.NY) IST=IST-NY DO 150 IZ=1,NZ IF (IFLAG.EQ.3) THEN KY=(IST-1)*NZ+IZ READ (3,REC=KY) (MX(IX,IZ),IX=1,NX) ELSE READ (1) (MX(IX,IZ),IX=1,NX) ENDIF 150 CONTINUE C Z-TRANSLATION ON A SECTION (MX(IX,IZ)) DO 200 IZ=1,NZ IZ1=NPT1(3)+IZ IF (IZ1.GT.NZ) IZ1=IZ1-NZ IZ2=IZ1+1 IF (IZ2.GT.NZ) IZ2=IZ2-NZ C X-TRANSLATION ON A SECTION (MX(IX,IZ)) DO 200 IX=1,NX IX1=NPT1(1)+IX IF (IX1.GT.NX) IX1=IX1-NX IX2=IX1+1 IF (IX2.GT.NX) IX2=IX2-NX C LINEAR INTRAPOLATION ON A SECTION (MX(IX,IZ)) C FIRST: LINEAR INTRAPOLATION ON Z DIRECTION XX1=SPT1(3)*(MX(IX1,IZ1)-MX(IX1,IZ2))+MX(IX1,IZ2) XX2=SPT1(3)*(MX(IX2,IZ1)-MX(IX2,IZ2))+MX(IX2,IZ2) C SECOND: LINEAR INTRAPOLATION ON X DIRECTION LX(IX,IZ)=SPT1(1)*(XX1-XX2)+XX2 200 CONTINUE DO 300 IX=1,NX DO 300 IZ=1,NZ IF (ISECT.EQ.1) GO TO 250 MX(IX,IZ)=KX(IX,IZ) 250 KX(IX,IZ)=LX(IX,IZ) 300 CONTINUE IF (IFLAG.EQ.3.OR.MOD(IST,NY).NE.0) GO TO 350 REWIND 1 READ (1) READ (1) 350 IF (ISECT.EQ.1) THEN C BACK TO READ THE SECOND SECTION FOR THE LINEAR C INTRAPOLATION ALONG Y-DIRECTION OF A 3D-MAP ISECT=2 GO TO 100 ENDIF C FINALLY: LINEAR INTRAPOLATION ON Y DIRECTION C BETWEEN TWO SECTIONS DO 450 IZ=1,NZ DO 400 IX=1,NX LX(IX,IZ)=SPT1(2)*(MX(IX,IZ)-LX(IX,IZ))+LX(IX,IZ) IF (IFLAG.NE.3) GO TO 400 XMAX=AMAX1(FLOAT(LX(IX,IZ)),XMAX) XMIN=AMIN1(FLOAT(LX(IX,IZ)),XMIN) 400 CONTINUE IF (IFLAG.EQ.3) WRITE (1) (LX(IX,IZ),IX=1,NX) 450 CONTINUE RETURN END C ------------------------------------------------------------------ SUBROUTINE SEARCH COMMON /PEAKS/ NSYM,NPIC,DM,XMAX(3),XX(4,400) COMMON /TRANN/TL(3,4),TS(3,24),FS(3,3,24),NDIFF,MN,NALIM,MLAT,NPC COMMON /TAPE/ NOSET,CELL(6),NEQV,NCENT,LATT,NATM,IS(3,3,24) COMMON /CONST/ NEX,KUSER1,DTOR,NNX,NNY,NNZ DIMENSION NSTORE(130000) C KUSER1 = MAXIMUM NUMBER OF PEAKS TO BE FOUND + 20, ALSO MAXIMUM C NUMBER OF PEAKS FOR INTERPRETATION AND DIMENSION OF SEVERAL ARRAYS KUSER1 = 400 C KUSER2 = SIZE OF ARRAY NSTORE FOR STORING 3 SECTIONS OF E-MAP KUSER2 = 130000 IF (NPC .LE. 0) GO TO 760 NPIC = MAX0(30,NPC) GO TO 800 760 NAT = MIN0((11*NATM+13)/9, KUSER1-20) NPIC = MIN0((3*NATM+1)/2, KUSER1-20) NPIC = MIN0(NPIC,NAT) NPIC = MAX0(NPIC,30) C HALVE Y-AXIS BY C.OF.S. OR LATTICE TYPE IF POSSIBLE 800 IHALF=0 IF (NCENT.EQ.1) IHALF=-1 IF (IHALF.NE.0) GO TO 888 GO TO (888,886,888,886,886,886,888), LATT 886 IHALF = 1 888 CALL CENTRE (1,1) C EXPAND TO FULL SPACE GROUP SYMMETRY C PUT CENTRING TRANSLATIONS IN TL(I,J) GO TO (940,890,890,890,890,910,920),LATT 890 CALL CENTRE(2,LATT) GO TO 940 910 CALL CENTRE(2,2) CALL CENTRE(3,3) CALL CENTRE(4,4) GO TO 940 920 CALL CENTRE(2,6) CALL CENTRE(3,7) 940 DO 1000 I=1,NEQV IF (I.EQ.1.OR.IHALF.NE.0) GO TO 1000 C HALVE Y-AXIS BY SYMMETRY OP. IF POSSIBLE DO 990 K=1,3 IF (IS(K,K,I).EQ.0) GO TO 1000 DO 980 J=1,3 IF(J.NE.K.AND.IS(J,K,I).NE.0) GO TO 1000 980 CONTINUE 990 CONTINUE IF (IS(2,2,I).EQ.(-1).AND.ABS(TS(2,I)).LT.1E-6) IHALF=-1 IF (IS(2,2,I).EQ.1.AND.ABS(TS(2,I)-0.5).LT.1E-6) IHALF=1 1000 CONTINUE NSYM=NEQV*(NCENT+1)*MLAT C SET UP CONSTANTS CA=COS(DTOR*CELL(4)) CB=COS(DTOR*CELL(5)) CC=COS(DTOR*CELL(6)) V=CELL(1)*CELL(2)*CELL(3)*SQRT(1.0-CA*CA-CB*CB-CC*CC+2.0*CA*CB*CC) XMAX(1)=DM*CELL(2)*CELL(3)*SIN(DTOR*CELL(4))/V XMAX(2)=DM*CELL(3)*CELL(1)*SIN(DTOR*CELL(5))/V XMAX(3)=DM*CELL(1)*CELL(2)*SIN(DTOR*CELL(6))/V DM=DM*DM C SEARCH MAP FOR PEAK POSITIONS AND RECORD PEAK HEIGHTS CALL PKSRCH(NSTORE,KUSER1,KUSER2,IHALF) RETURN END C ------------------------------------------------------------------ C FIND POSITIONS OF PEAKS BY FITTING QUADRATIC FUNCTION TO 19 POINTS SUBROUTINE PKSRCH(NR3D,KUSER1,KUSER2,IHALF) COMMON /PEAKS/ NSYM,NPIC,DM,XMAX(3),XX(4,400) COMMON /CONST/ N1,N2,DTOR,NNX,NNYY,NNZ COMMON /TAPE/ NOSET,CELL(6),NEQV,NCENT,LATT DIMENSION NR3D(KUSER2), XS(3), X1(3), IDIFF(19), B(19),T(3,3) C SET UP MATRIX TO CALCULATE DISTANCES AND ANGLES DO 700 I=4,6 J=8/I K=15/I T(J,K)=COS(DTOR*CELL(I)) T(K,J)=T(J,K) 700 CONTINUE DO 800 I=1,3 T(I,I)=1.0 DO 750 J=1,3 T(I,J)=T(I,J)*CELL(I)*CELL(J) 750 CONTINUE 800 CONTINUE C HALVE Y-AXIS IF POSSIBLE NNY=NNYY NNYOLD=NNY IF (IHALF.NE.0) NNY=NNY-NNY/2 NNXP2 = NNX + 2 NXZ = NNXP2 * (NNZ + 2) NXZ3 = 3 * NXZ IF (NXZ3 .LE. KUSER2) GO TO 1020 WRITE (6,940) KUSER2, NXZ3 940 FORMAT(//18X,33H NOT ENOUGH ROOM IN ARRAY NSTORE./ 1 18X,18HSPACE AVAILABLE =,I7,10X,17HSPACE REQUIRED =,I7) CALL ERROR3 C INITIALISE CONSTANTS 1020 DX = 1.0 / FLOAT(NNX) DY = 1.0/FLOAT(NNYOLD) DZ = 1.0/FLOAT(NNZ) LEVEL = 0 LIMIT = MIN0(KUSER1, 2*NPIC) C SET UP TABLE OF OFFSETS TO LOOK UP 19 POINTS IN E-MAP 1100 IDIFF(1) = -NXZ - 1 IDIFF(2) = -NXZ - NNXP2 IDIFF(3) = -NXZ IDIFF(4) = -NXZ + NNXP2 IDIFF(5) = -NXZ + 1 IDIFF(6) = -NNXP2 - 1 IDIFF(7) = -1 IDIFF(8) = NNXP2 - 1 IDIFF(9) = -NNXP2 IDIFF(10) = 0 DO 1120 I=1,9 J=20-I IDIFF(J) = -IDIFF(I) 1120 CONTINUE C INITIALISE VARIABLES NO = 0 IY = -1 NY = 0 1200 REWIND 1 READ (1) READ (1) IF (IY+2.EQ.NNYOLD) GO TO 1400 C READ IN FIRST SECTION (END OF LAST UNIT CELL) 1300 MAX=NXZ ISKIP=NNYOLD-1 DO 1305 I=1,ISKIP READ (1) 1305 CONTINUE 1310 CALL RDSECT(NR3D,MAX,NNXP2,NNZ,NXZ3,KUSER2) REWIND 1 C READ SECOND SECTION (START OF UNIT CELL) READ (1) READ (1) CALL RDSECT(NR3D,MAX,NNXP2,NNZ,NXZ3,KUSER2) C READ IN THE NEXT SECTION 1400 MX = MAX - NXZ + NNX + 1 CALL RDSECT(NR3D,MAX,NNXP2,NNZ,NXZ3,KUSER2) IY = IY + 1 NY = MOD(NY+2, 3) - 1 KK = NXZ3 IF (NY) 1440,1460,1500 1440 KK = -NXZ3 1460 DO 1480 I=1,5 IDIFF(I) = IDIFF(I) - KK 1480 CONTINUE IF (NY .EQ. 0) GO TO 1540 1500 DO 1520 I=15,19 IDIFF(I) = IDIFF(I) - KK 1520 CONTINUE C SEARCH ONE SECTION OF THE E-MAP 1540 DO 2000 IZ=1,NNZ MN = MX + 3 MX = MX + NNXP2 DO 1980 IX=MN,MX IF (NR3D(IX) .LT. LEVEL) GO TO 1980 C LOCATE GRID POINT WITH MAXIMUM DENSITY DO 1560 I=1,9 J = IDIFF(I) + IX IF (NR3D(IX) .LE. NR3D(J)) GO TO 1980 1560 CONTINUE DO 1580 I=11,19 J = IDIFF(I) + IX IF (NR3D(IX) .LT. NR3D(J)) GO TO 1980 1580 CONTINUE C FIT QUADRATIC FUNCTION TO 19 POINTS C DENS = A + C*X + D*Y + E*Z - 0.5*F*(X*X + Y*Y + Z*Z) DO 1600 I=1,19 J = IDIFF(I) + IX B(I) = NR3D(J) 1600 CONTINUE B1 = B(3) + B(7) + B(9) + B(11) + B(13) + B(17) B2 = B(1) + B(2) + B(4) + B(5) + B(6) + B(8) + B(12) + B(14) + 1 B(15) + B(16) + B(18) + B(19) F = (30.0 * B(10) + 11.0 * B1 - 8.0 * B2) / 63.0 C = (B(5)+B(12)+B(13)+B(14)+B(19)-B(1)-B(6)-B(7)-B(8)-B(15))/10.0 DELTAX = C / F IF (ABS(DELTAX) .GT. 1.0) GO TO 1620 D = (B(15)+B(16)+B(17)+B(18)+B(19)-B(1)-B(2)-B(3)-B(4)-B(5))/10.0 DELTAY = D / F IF (ABS(DELTAY) .GT. 1.0) GO TO 1620 E = (B(4)+B(8)+B(11)+B(14)+B(18)-B(2)-B(6)-B(9)-B(12)-B(16))/10.0 DELTAZ = E / F IF (ABS(DELTAZ) .LE. 1.0) GO TO 1640 1620 DELTAX = 0.0 DELTAY = 0.0 DELTAZ = 0.0 1640 XT = (FLOAT(IX-MN+1) + DELTAX) * DX YT = (FLOAT(IY) + DELTAY) * DY ZT = (FLOAT(IZ) + DELTAZ) * DZ C PEAK HEIGHT INTERPOLATION - NOT SUITABLE IF PEAK SHAPE IS POOR C A = (9.0 * B(10) + 4.0 * B1 - B2) / 21.0 C B(10) = AMAX1(A+0.5*(C*DELTAX+D*DELTAY+E*DELTAZ), B(10)) NOP1 = NO+1 XX(1,NOP1) = XT XX(2,NOP1) = YT XX(3,NOP1) = ZT XX(4,NOP1) = B(10) IF (NO .EQ. 0) GO TO 1820 IR=0 C IF TWO PEAKS ARE CLOSER THAN DM ANGSTROMS ELIMINATE THE SMALLER DO 1800 K=1,NSYM CALL OPER(K,XS,XT,YT,ZT) DO 1780 I=1,NO DO 1720 L=1,3 X1(L) = XX(L,I) - XS(L) 1680 IF (ABS(X1(L)) .LE. 0.5) GO TO 1700 X1(L) = X1(L) - SIGN(1.0, X1(L)) GO TO 1680 1700 IF (ABS(X1(L)) .GT. XMAX(L)) GO TO 1780 1720 CONTINUE IF (QUAD(X1,X1,T) .GT. DM) GO TO 1780 IF (IR.GT.0) XX(4,IR)=0.0 IR=0 IF (B(10) .LE. XX(4,I)) GO TO 1980 XX(1,I) = XT XX(2,I) = YT XX(3,I) = ZT XX(4,I) = B(10) IR=I 1780 CONTINUE 1800 CONTINUE IF (IR.GT.0) GO TO 1980 1820 NO = NOP1 IF (NO .LT. LIMIT) GO TO 1980 CALL SORT3(XX,KUSER1,NO,4,LEVEL) NO = NPIC LEVEL = XX(4,NPIC) + 0.5 1980 CONTINUE 2000 CONTINUE IF (IY .GE. NNY) GO TO 2100 IF (IY - NNYOLD + 2) 1400,1200,1400 C SORT PEAKS IN ORDER OF PEAK HEIGHT 2100 CALL SORT3(XX,KUSER1,NO,4,LEVEL) IF (NO .GE. NPIC) GO TO 2200 C INSUFFICIENT PEAKS FOUND - LOWER SCAN LEVEL AND TRY AGAIN NPIC=NO+(NPIC-NO)/2 LEVEL = LEVEL - 100 GO TO 1100 2200 CONTINUE RETURN END C ------------------------------------------------------------------ C SORT PEAKS IN ORDER OF PEAK HEIGHT OR IN ORDER OF PLOTTING SUBROUTINE SORT3(XX,KUSER1,NPIC,N,LEVEL) DIMENSION XX(4,KUSER1),T(4) IF (NPIC.NE.0) GO TO 500 WRITE (6,200) LEVEL 200 FORMAT(/1X,' NO PEAKS HIGHER THEN',I4, 1 ' HAS BEEN FOUND') CALL ERROR3 500 IF (NPIC.EQ.1) RETURN INT=2 1000 INT=INT+INT IF (INT.LT.NPIC) GO TO 1000 INT=MIN0(NPIC,(3*INT)/4-1) 1020 INT=INT/2 IFIN=NPIC-INT DO 1200 II=1,IFIN I=II J=I+INT IF (XX(N,I).GE.XX(N,J)) GO TO 1200 DO 1060 K=1,4 T(K)=XX(K,J) 1060 CONTINUE 1080 DO 1100 K=1,4 XX(K,J)=XX(K,I) 1100 CONTINUE J=I I=I-INT IF (I) 1140,1140,1120 1120 IF (XX(N,I).LT.T(N)) GO TO 1080 1140 DO 1160 K=1,4 XX(K,J)=T(K) 1160 CONTINUE 1200 CONTINUE IF (INT.NE.1) GO TO 1020 RETURN END C ------------------------------------------------------------------ C RETRIEVE CENTRING TRANSLATIONS SUBROUTINE CENTRE(J,L) COMMON /TRANN/ TL(3,4),TS(3,24),FS(3,3,24),N1,N2,N3,MLAT,NPC DIMENSION TST(21) DATA TST/0.,0.,0., 0.,0.5,0.5, 0.5,0.,0.5, 0.5,0.5,0., 0.5,0.5,0.5 1 , 0.333333,0.666667,0.666667, 0.666667,0.333333,0.333333/ MLAT=J M=3*L-2 TL(1,J)=TST(M) TL(2,J)=TST(M+1) TL(3,J)=TST(M+2) RETURN END C ------------------------------------------------------------------ SUBROUTINE RDSECT(NR3D,MAX,NNXP2,NNZ,NXZ3,KUSER2) DIMENSION NR3D(KUSER2) IF (MAX .GE. NXZ3) MAX = 0 MX = MAX MAX = MAX - 2 DO 1320 IZ=1,NNZ MIN = MAX + 3 MAX = MAX + NNXP2 READ (1) (NR3D(IX),IX=MIN,MAX) NR3D(MAX+1) = NR3D(MIN) NR3D(MAX+2) = NR3D(MIN+1) 1320 CONTINUE MIN = MAX + 3 MAX = MAX + NNXP2 + NNXP2 + 2 DO 1340 IX=MIN,MAX MX = MX + 1 NR3D(IX) = NR3D(MX) 1340 CONTINUE RETURN END C ------------------------------------------------------------------ C APPLY J'TH SYMMETRY ELEMENT TO X,Y,Z & PUT RESULT IN XN SUBROUTINE OPER(J,XN,X,Y,Z) COMMON /TAPE/ N1,CELL(6),NEQV,NCENT,LATT,NATM COMMON /TRANN/ TL(12),TS(72),FS(216),NN1,NN2,NN3,MLAT,NPC DIMENSION XN(3) ISYM=MOD(J,NEQV) IF (ISYM.EQ.0) ISYM=NEQV IP=(J-1)/NEQV ILAT=3*MOD(IP,MLAT) JT=3*(ISYM-1) JJ=9*ISYM-8 DO 20 L=1,3 IND1=JT+L IND2=ILAT+L XN(L)=X*FS(JJ)+Y*FS(JJ+1)+Z*FS(JJ+2) IF (IP.GE.MLAT) XN(L)=-XN(L) XN(L)=XN(L)+TS(IND1)+TL(IND2) JJ=JJ+3 20 CONTINUE RETURN END C ------------------------------------------------------------------- C FUNCTION USED IN THE CALCULATION OF DISTANCES AND ANGLES FUNCTION QUAD(X1,X2,T) DIMENSION X1(3),X2(3),T(3,3) QUAD=0.0 DO 1000 I=1,3 QUAD = QUAD+X2(I)*(T(I,1)*X1(1)+T(I,2)*X1(2)+T(I,3)*X1(3)) 1000 CONTINUE RETURN END ************************************************************************ * * * A A PPPPPP M M * * A A A A P P MM MM * * A A A A P P M M M M * * A A A A PPPPPP M M M * * AAAAAAA AAAAAAA P M M * * A A A A P M M * * A A A A P M M * * * * PROGRAM OF AUTOMATIC ANALYSIS OF PATTERSON MAP * * VERSION 1995 * ************************************************************************ SUBROUTINE AAPM COMMON UP(666),VP(666),WP(666),EX(4000),EY(4000),EZ(4000), 1 CX(4000),CY(4000),CZ(4000),PW(4002) COMMON /PERIF/ TWOPI,VECR(8,3),MFP COMMON /PEAKS/ NN,NPIC,DM,XMAX(3),AX(4,400),NEP(400) COMMON /AAPMP/ IAPA,IHAR,NHAR,MC1,NHV,XH(40),YH(40),ZH(40) COMMON /TAPE/ NOSET,PARA(6),NEQV,NCENT,LATT COMMON /CONST/ NEX,KUSER1,DTOR,NP(3),ALPHA,BETA,GAMA COMMON /TRANN/ TL(3,4),TS(3,24),FS(3,3,24),NN1,NN2,NN3,MLAT DIMENSION X1(196),Y1(196),Z1(196),RR(4),X3(3),ITY(3),XX3(3) DIMENSION U1(3),U2(3),U3(3),A(3,3),AT(3,5),T2(3,24),YY3(3,2) DIMENSION MX(40000),KX(40000),LX(40000) WRITE (6,50) 50 FORMAT(//1X,28HAUTOMATIC PATTERSON ANALYSIS,27X, 1 20H VERSION APR. 1995) IF (IAPA.EQ.2) GO TO 135 IF (NCENT.EQ.1) GO TO 130 IF (NEQV.EQ.1) GO TO 940 C CHECKING THE SPACE GROUP TYPE FOR P 2 2 2 OR P 4(6) 2 2 ITY(1)=0 ITY(2)=0 ITY(3)=0 DO 120 J=1,NEQV IF (J.EQ.1) GO TO 120 DO 100 L1=1,3 DO 100 L2=1,3 100 A(L1,L2)=FS(L2,L1,1)-FS(L2,L1,J) ITYPE=0 DO 110 K=1,3 RNR=ABS(A(K,1))+ABS(A(K,2))+ABS(A(K,3)) IF (RNR.GT.0.001) GO TO 110 ITYPE=ITYPE+1 ITY(K)=ITY(K)+1 110 CONTINUE IF (ITYPE.NE.0) GO TO 120 IF (ABS(A(1,1)-1.0).LT.0.01.AND.ABS(A(1,2)-1.0).LT.0.01 1 .AND.ABS(A(2,1)-1.0).LT.0.01.AND.ABS(A(2,2)-1.0).LT.0.01 2 .AND.ABS(A(3,3)-2.0).LT.0.01) ITYPE=1 IF (ABS(A(1,1)+A(1,2)+A(2,1)+A(2,2)).LT.0.01 1 .AND.ABS(A(3,3)-2.0).LT.0.01) ITYPE=1 IF (ITYPE.EQ.0) GO TO 135 120 CONTINUE I=NEQV-1 IF (ITY(1).EQ.I.OR.ITY(2).EQ.I.OR.ITY(3).EQ.I) GO TO 130 IF (ITY(1).EQ.0.OR.ITY(2).EQ.0.OR.ITY(3).EQ.0) GO TO 130 ITYPE=ITY(1)+ITY(2)+ITY(3) C ITYPE.EQ.3 THE CASE WITH SPACE GROUP TYPE - P 2 2 2 C ITYPE.GT.3 THE CASE WITH SPACE GROUP TYPE - P 4 2 2 OR P 6 2 2 IF (ITYPE.GE.3) GO TO 135 130 ITYPE=0 135 NONH=0 ICN=NCENT NCENT=1 DO 140 J=1,24 DO 140 I=1,3 T2(I,J)=TS(I,J) 140 TS(I,J)=0.0 REWIND 8 READ (8,195) NPP=0 NPATT=0 NHAR=MAX0(IHAR,NHAR) 150 READ (8,195,END=205) U2,DUM,IDUM DO 160 I=1,3 U2(I)=AMOD(U2(I)+10.0,1.0) IF (U2(I).LT.0.001) U2(I)=0.001 IF (U2(I).GT.0.999) U2(I)=0.999 160 CONTINUE DO 170 I=1,3 IF (ABS(AMOD(U2(I)+0.5,1.0)-0.5)*PARA(I).GT.1.0) GO TO 180 170 CONTINUE GO TO 150 180 IF (DUM.LT.0.01) GO TO 150 NPP=NPP+1 CALL CHECK(U2,CX,CY,CZ,NONH,IG3,NEQ,0) IF (IG3.NE.0) GO TO 185 NPP=NPP-1 GO TO 150 185 DO 190 K=NONH-NEQ+1,NONH 190 PW(K)=DUM IF (NPP.EQ.IHAR) NPATT=NONH IF (NONH.EQ.4000) GO TO 200 IF (NPP.LE.NHAR.AND.NPP.LE.80) GO TO 150 195 FORMAT(11X,3F10.6,3X,F7.0,6X,I4) 200 NPP=NPP-1 205 NHAR=NPP IHAR=MIN0(IHAR,NPP) IF (NPATT.EQ.0) NPATT=NONH NCENT=ICN DO 220 J=1,24 DO 220 I=1,3 220 TS(I,J)=T2(I,J) IF (IAPA.EQ.2) GO TO 970 WRITE (6,210) IHAR 210 FORMAT(/9X,I3,' LARGEST PATTERSON PEAKS WERE ASSUMED ', 1 'TO BE HARKER PEAKS') NHV=1 NAT=0 NATOM=0 C FIRST OF ALL, TRY WITH THE POSITION X=0.0, Y=0.0, Z=0.0 X3(1)=0.0 X3(2)=0.0 X3(3)=0.0 CALL CHECK(X3,EX,EY,EZ,NAT,IG3,NEQ,1) NATOM=NATOM+1 AX(1,NATOM)=X3(1) AX(2,NATOM)=X3(2) AX(3,NATOM)=X3(3) CALL THPK(X3,ISGN,NHK,0) CALL CHECKP(0.50,X3,NPATT,NHK,NATOM,NAT,ISGN,NEQ) IF (ISGN.NE.1) AX(4,NATOM)=4000.0 NCYC=-1 ICYC=1 DO 820 I2=1,NCENT+1 NCYC=-NCYC 230 DO 810 K2=1,NEQV IF (I2.EQ.1.AND.K2.EQ.1) GO TO 810 DO 250 L1=1,3 DO 240 L2=1,3 240 A(L1,L2)=FS(L2,L1,1)-NCYC*FS(L2,L1,K2) U3(L1)=-TS(L1,1)+NCYC*TS(L1,K2) 250 CONTINUE IF (ITYPE.EQ.0) GO TO 400 IF (ITYPE.GT.3) GO TO 280 C THE CASE WITH S.P.G. TYPE OF P 2 2 2 IF (ICYC.NE.1) GO TO 270 IF (ABS(A(1,1)+A(2,2)-4.0).GT.0.001) GO TO 810 Z222=AMOD(U3(3)+10.0,1.0) GO TO 300 270 IF (ABS(A(1,1)+A(3,3)-4.0).GT.0.001) GO TO 810 Y222=AMOD(U3(2)+10.0,1.0) GO TO 420 C THE CASE WITH S.P.G. TYPE OF P 4 2 2 OR P 6 2 2 280 IF (ICYC.NE.1) GO TO 290 IF (ABS(A(1,1)+A(1,2)+A(2,1)+A(2,2)).GT.0.001 1 .OR.ABS(A(3,3)-2.0).GT.0.001) GO TO 810 GO TO 300 290 IF (ABS(A(1,1)+A(2,2)-4.0).GT.0.001 1 .OR.ABS(A(3,3)).GT.0.001) GO TO 810 Z222=AMOD(U3(3)+10.0,1.0) GO TO 420 300 LL=0 DO 360 II=1,NPATT IF (LL.EQ.3) GO TO 360 IF (ITYPE.GT.3) GO TO 350 IF (ABS(AMOD(CZ(II)+Z222+10.5,1.0)-0.5).GT.0.015) GO TO 360 LL=LL+1 IF (LL.EQ.1) X3(1)=AMOD((CX(II)+U3(1))/2.0+10.0,1.0) IF (LL.EQ.1) X3(2)=AMOD((CX(II)+U3(2))/2.0+10.0,1.0) YY3(LL,1)=AMOD((CX(II)+U3(1))/2.0+10.0,1.0) YY3(LL,2)=AMOD((CY(II)+U3(2))/2.0+10.0,1.0) GO TO 360 350 IF (ABS(AMOD(CX(II)+CY(II)+10.5,1.0)-0.5).GT.0.015) GO TO 360 LL=LL+1 IF (LL.EQ.1) X3(3)=AMOD((CZ(II)+U3(3))/2.0+10.0,1.0) XX3(LL)=AMOD((CZ(II)+U3(3))/2.0+10.0,1.0) 360 CONTINUE IF (LL.EQ.0) GO TO 380 LL=LL*2+1 ICYC=ICYC+1 GO TO 230 380 WRITE (6,390) 390 FORMAT(1X,'* * * HAVE NOT FOUND THE HARKER PEAK IN', 1 ' THE LIST OF PATTERSON PEAKS ABOVE * * *'/) GO TO 940 C SEARCH PROPER MATRIX TO SOLVE PEAKS ASSUMED AS HARKER PEAK C ASSIGN ELEMENT A(K,K)=1 FOR UN-NORMAL MATRIX 400 DO 410 K=1,3 RNR=ABS(A(K,1))+ABS(A(K,2))+ABS(A(K,3)) IF (RNR.GT.0.001) GO TO 410 A(K,K)=1.0 410 CONTINUE C FIND A PROPER MATRIX, SOLVE PATTERSON PEAKS ONE BY ONE 420 DO 800 I5=1,NPATT IF (ITYPE.EQ.0) GO TO 540 IF (ITYPE.GT.3) GO TO 520 C SOLVING PATTERSON PEAKS IN THE CASE WITH THE TYPE OF P 2 2 2 IF (ABS(AMOD(CZ(I5)+Z222+10.5,1.0)-0.5).LE.0.015) GO TO 800 IF (ABS(AMOD(CY(I5)+Y222+10.5,1.0)-0.5).GT.0.015) GO TO 800 X3(3)=AMOD((CZ(I5)+U3(3))/2.0+10.0,1.0) TEMPX3=X3(3) GO TO 670 C SOLVING PATTERSON PEAKS IN THE CASE WITH THE TYPE OF P 4 (6) 2 2 520 IF (ABS(AMOD(CZ(I5)+Z222+10.5,1.0)-0.5).GT.0.015) GO TO 800 X3(1)=AMOD(CX(I5)/2.0+10.0,1.0) X3(2)=AMOD(CY(I5)/2.0+10.0,1.0) GO TO 670 540 DO 560 I=1,3 DO 560 J=1,5 J0=MOD(J-1,3)+1 560 AT(I,J)=A(I,J0) U1(1)=U3(1)+CX(I5) U1(2)=U3(2)+CY(I5) U1(3)=U3(3)+CZ(I5) DO 650 L=1,4 IF (L.EQ.1) GO TO 620 IF (ABS(RR(1)).LE.0.001) GO TO 810 DO 610 L3=1,4,3 L4=L+L3-2 DO 600 L0=1,3 IF (L4.EQ.6) GO TO 580 AT(L0,L4)=U1(L0) IF (L.EQ.2) GO TO 600 580 L5=MOD(L4-2,3)+1 AT(L0,L4-1)=A(L0,L5) 600 CONTINUE 610 CONTINUE 620 RR(L)=0.0 DO 640 I=1,3 AB=1.0 BA=1.0 DO 630 J=1,3 I3=I+J-1 I4=7-I-J AB=AT(J,I3)*AB 630 BA=AT(J,I4)*BA 640 RR(L)=RR(L)+AB-BA 650 CONTINUE DO 660 I=1,3 AT(I,3)=A(I,3) X3(I)=RR(I+1)/RR(1) 660 X3(I)=AMOD(X3(I)+10.0,1.0) C LOOK FOR DUPLICATE PEAK 670 CALL CHECK(X3,EX,EY,EZ,NAT,IG3,NEQ,1) IF (IG3.EQ.0) GO TO 700 NATOM=NATOM+1 AX(1,NATOM)=X3(1) AX(2,NATOM)=X3(2) AX(3,NATOM)=X3(3) C GENERATE PATTERSON PEAKS (IT IS HARKER PEAKS HERE) CALL THPK(X3,ISGN,NHK,0) C NOW CHECKING SOLUTIONS CALL CHECKP(0.50,X3,NPATT,NHK,NATOM,NAT,ISGN,NEQ) 700 IF (ITYPE.EQ.0) GO TO 800 IF (LL.EQ.1) GO TO 830 ID=LL/2 IF (ITYPE.GT.3) GO TO 750 X3(1)=YY3(ID,1) X3(2)=YY3(ID,2) X3(3)=TEMPX3 IF (MOD(LL,2).EQ.0) X3(3)=Z222/2.0 LL=LL-1 GO TO 670 750 X3(3)=XX3(ID) LL=LL-2 GO TO 670 800 CONTINUE IF (ITYPE.NE.0) GO TO 830 810 CONTINUE 820 CONTINUE 830 IF (NATOM.EQ.0) GO TO 940 IF (NATOM.EQ.1) GO TO 970 DO 850 I=1,NATOM-1 II=I+1 DO 840 K=II,NATOM IF (AX(4,K).LE.AX(4,I)) GO TO 840 DO 835 KK=1,4 TT=AX(KK,I) AX(KK,I)=AX(KK,K) 835 AX(KK,K)=TT 840 CONTINUE 850 CONTINUE C CHECKING NON-HARKER PEAKS BETWEEN HEAVY ATOMS NAT=0 NUMB=NATOM NATOM=1 CALL EQPO(AX(1,1),AX(2,1),AX(3,1),X1,Y1,Z1,NEP(1),1) DO 890 I=2,NUMB X3(1)=AX(1,I) X3(2)=AX(2,I) X3(3)=AX(3,I) CALL CHECK(X3,EX,EY,EZ,NAT,IG3,NEQ,1) IF (IG3.EQ.0) GO TO 890 CALL THPK(X3,ISGN,NHK,1) NATOM=NATOM+1 NEP(NATOM)=NEQ CALL CHECKP(0.55,X3,NPATT,NHK,NATOM,NAT,ISGN,NEQ) 890 CONTINUE IF (NATOM.EQ.1) GO TO 970 NCA=1 DO 930 I=1,NATOM-1 II=I+1 DO 920 K=II,NATOM IF (NEP(K).LE.NEP(I)) GO TO 920 IF (I.NE.NCA) GO TO 895 NCA=K GO TO 898 895 IF (K.EQ.NCA) NCA=I 898 DO 900 KK=1,4 TT=AX(KK,I) AX(KK,I)=AX(KK,K) 900 AX(KK,K)=TT ITT=NEP(I) NEP(I)=NEP(K) NEP(K)=ITT 920 CONTINUE 930 CONTINUE GO TO 970 940 WRITE (6,950) 950 FORMAT(//1X,20(2H* ), 1 /7X,'THE PROGRAM FAILS ON FINDING ATOMS BY WAY OF ', 2 'HARKER ANALYSIS.'/7X,'PLEASE CONSIDER THE POSSIBILITY OF ', 3 'THAT A HEAVY ATOM SITS ON'/7X,'THE ORIGIN IN THE UNIT CELL', 4 ' ( 0.0, 0.0, 0.0 ).'//7X,'IT SHOULD BE BETTER SOLVE THIS ', 5 'STRUCTURE BY DIRECT METHODS.'//2X,'NOTE THAT:'/' THE FOLLOW', 6 'ING OUTPUT IS NO-MEANING BUT SOME PATTERSON PEAKS ON THE MAP', 7 /1X,20(2H* )) STOP' --- PAT.- ANA. FAILED ---' C PRINT HEAVY ATOM OUT 960 FORMAT(/3X,I3,' PEAKS WERE ASSUMED TO BE NON-HARKER PEAKS ', 1 'FROM THE ATOMS LISTED ABOVE',/30X,'ATOMS FOUND AS FOLLOWS') 970 NAT=0 IF (IAPA.NE.2.AND.MC1.NE.0) NATOM=MIN0(MC1,NATOM) IF (IAPA.EQ.2) NATOM=MC1 IF (IAPA.EQ.2) WRITE (6,980) IF (IAPA.NE.2) WRITE (6,990) 980 FORMAT(/24X,'KNOWN ATOMS SUPPLIED BY THE USER',//18X,'ATOM', 1 7X,'X',11X,'Y',11X,'Z') 990 FORMAT(23X,'ATOMIC POSITIONS FOUND AS FOLLOWS',//18X, 1 'ATOM',7X,'X',11X,'Y',11X,'Z') DO 1100 I=1,NATOM IF (IAPA.NE.2) GO TO 1010 AX(1,I)=XH(I) AX(2,I)=YH(I) AX(3,I)=ZH(I) AX(4,I)=4000.0 C NON-HARKER ANALYSIS IS BEGUN 1010 CALL EQPO(AX(1,I),AX(2,I),AX(3,I),X1,Y1,Z1,NEQ,1) 1030 FORMAT(/1X,'* * * THE ABOVE ATOMIC SITES HAVE BEEN CHECKED BY ' 1 ,'NON-HARKER PEAKS WITH ATOM ',I2,' * * *') 1040 FORMAT(/18X,I3,2X,3(F10.4,2X),2X) 1060 FORMAT(23X,3(F10.4,2X),2X) DO 1080 J=1,NEQ NAT=NAT+1 EX(NAT)=X1(J) EY(NAT)=Y1(J) EZ(NAT)=Z1(J) IF (J.EQ.1) WRITE (6,1040) I,X1(J),Y1(J),Z1(J) IF (J.NE.1) WRITE (6,1060) X1(J),Y1(J),Z1(J) 1080 CONTINUE 1100 CONTINUE IF (NATOM.GT.1.AND.IAPA.NE.2) WRITE (6,1030) NCA IF (IAPA.NE.4) GO TO 1115 MFP=2 NN2=1 VECR(1,1)=AX(1,1) VECR(1,2)=AX(2,1) VECR(1,3)=AX(3,1) CALL MINFN (LX,MX,KX,NP(1),NP(2),NP(3)) RETURN 1115 IF (IAPA.EQ.1) GO TO 1230 C MAKE USE OF THE PEAK LIST TO SOLVE NONHARKER PEAKS WRITE (6,960) NHAR WRITE (6,1110) 1110 FORMAT(/18X,'ATOM',7X,'X',11X,'Y',11X,'Z',8X,'WT'/) NHV=NATOM N4=1 REWIND 8 READ (8,195) 1120 READ (8,195,END=1230) U3,DUM,IDUM DO 1130 I=1,3 1130 U3(I)=AMOD(U3(I)+10.0,1.0) DO 1140 I=1,3 1140 IF (ABS(AMOD(U3(I)+0.5,1.0)-0.5)*PARA(I).GT.1.0) GO TO 1150 GO TO 1120 1150 N4=N4+1 DO 1200 I=1,NHV CALL EQPO(AX(1,I),AX(2,I),AX(3,I),X1,Y1,Z1,NEQ,1) DO 1200 J=1,NEQ N2=1 DO 1190 L1=1,2 N2=-N2 X3(1)=AMOD(X1(J)+N2*U3(1)+10.0,1.0) X3(2)=AMOD(Y1(J)+N2*U3(2)+10.0,1.0) X3(3)=AMOD(Z1(J)+N2*U3(3)+10.0,1.0) CALL CHECK(X3,EX,EY,EZ,NAT,IG3,NEQ,1) IF (IG3.EQ.0) GO TO 1190 CALL THPK(X3,ISGN,NHK,1) C CHEACKING NON-HARKAER PEAKS BETTEN HEAVY ATOM AND LIGHT ATOM NATOM=NATOM+1 CALL CHECKP(0.75,X3,NONH,NHK,NATOM,NAT,ISGN,NEQ) IF (ISGN.EQ.1) GO TO 1190 NWT=INT(AX(4,NATOM)) WRITE (6,1210) NATOM,X3,NWT IF (NATOM.EQ.200) GO TO 1230 1190 CONTINUE 1200 CONTINUE IF (N4-NHAR) 1120,1230,1230 1210 FORMAT(18X,I3,2X,3(F10.4,2X),2X,I4) 1230 REWIND 8 WRITE (8,1240) NATOM 1240 FORMAT(I4) DO 1300 J=1,NATOM IF (J.EQ.NATOM) GO TO 1260 K=J+1 DO 1250 I=K,NATOM IF (AX(4,I).LE.AX(4,J)) GO TO 1250 DO 1245 K=1,4 TT=AX(K,J) AX(K,J)=AX(K,I) AX(K,I)=TT 1245 CONTINUE 1250 CONTINUE 1260 WRITE (8,1350) (AX(I,J),I=1,4),J 1300 CONTINUE 1350 FORMAT(11X,3F10.6,3X,F7.0,6X,I4) IF (IAPA.NE.1.AND.NATOM.EQ.NHV) WRITE (6,1400) 1400 FORMAT(1X,18X,'NO ATOMS TO BE FOUND BY NON-HARKER ANALYSIS.') NPIC=NATOM RETURN END C ------------------------------------------------------------------ SUBROUTINE CHECK(X,CX,CY,CZ,NAT,IG3,NEQ,MARK) DIMENSION X(3),X2(3),X1(196),Y1(196),Z1(196) DIMENSION CX(4000),CY(4000),CZ(4000),D(3) IG3=0 IF (NAT.EQ.0) GO TO 100 DO 80 J=1,NAT X2(1)=CX(J) X2(2)=CY(J) X2(3)=CZ(J) DO 70 K=1,3 D(K)=AMOD(X(K)-X2(K)+10.5,1.0)-0.5 70 CONTINUE IF (DIS(D(1),D(2),D(3)).LT.0.75) GO TO 120 80 CONTINUE 100 IG3=1 CALL EQPO(X(1),X(2),X(3),X1,Y1,Z1,NEQ,MARK) DO 110 I=1,NEQ NAT=NAT+1 CX(NAT)=X1(I) CY(NAT)=Y1(I) CZ(NAT)=Z1(I) IF (NAT.EQ.4000) RETURN 110 CONTINUE 120 CONTINUE RETURN END C ----------------------------------------------------------------- SUBROUTINE EQPO(X,Y,Z,X1,Y1,Z1,NEQ,MARK) COMMON /TRANN/ TL(3,4),TS(3,24),FS(3,3,24),NN1,NN2,NN3,MLAT COMMON /TAPE/ NNN,PARA(6),NEQV,NCENT,LATT,NATM DIMENSION X1(196),Y1(196),Z1(196) DO 100 J=1,NEQV X1(J)=FS(1,1,J)*X+FS(2,1,J)*Y+FS(3,1,J)*Z+TS(1,J) Y1(J)=FS(1,2,J)*X+FS(2,2,J)*Y+FS(3,2,J)*Z+TS(2,J) Z1(J)=FS(1,3,J)*X+FS(2,3,J)*Y+FS(3,3,J)*Z+TS(3,J) 100 CONTINUE NEC=NEQV K=NEC IF (NCENT.EQ.0) GO TO 230 DO 200 J=1,NEQV X1(J+NEQV)=-X1(J) Y1(J+NEQV)=-Y1(J) Z1(J+NEQV)=-Z1(J) 200 CONTINUE K=NEC+NEC NEC=K 230 IF (MLAT.EQ.1) GO TO 250 DO 240 L=2,MLAT DO 240 LL=1,NEC K=K+1 X1(K)=X1(LL)+TL(1,L) Y1(K)=Y1(LL)+TL(2,L) Z1(K)=Z1(LL)+TL(3,L) 240 CONTINUE 250 NTQ=K DO 280 L=1,NTQ IF (L.EQ.NTQ) GO TO 280 K=NTQ-L+1 NK=K-1 DO 270 LL=1,NK IF (MARK.EQ.0) GO TO 255 D1=AMOD(X1(K)-X1(LL)+10.5,1.0)-0.5 D2=AMOD(Y1(K)-Y1(LL)+10.5,1.0)-0.5 D3=AMOD(Z1(K)-Z1(LL)+10.5,1.0)-0.5 GO TO 260 255 D1=AMOD(X1(K)+5.0,1.0)-AMOD(X1(LL)+5.0,1.0) D2=AMOD(Y1(K)+5.0,1.0)-AMOD(Y1(LL)+5.0,1.0) D3=AMOD(Z1(K)+5.0,1.0)-AMOD(Z1(LL)+5.0,1.0) 260 IF (DIS(D1,D2,D3).GT.0.75) GO TO 270 X1(K)=1000.0 GO TO 280 270 CONTINUE 280 CONTINUE NEQ=0 DO 300 II=1,NTQ IF (X1(II).GT.10.0) GO TO 300 NEQ=NEQ+1 X1(NEQ)=AMOD(X1(II)+10.0,1.0) Y1(NEQ)=AMOD(Y1(II)+10.0,1.0) Z1(NEQ)=AMOD(Z1(II)+10.0,1.0) 300 CONTINUE RETURN END C ----------------------------------------------------------- C CALCULATE THEORITICAL PATTERSON PEAKS SUBROUTINE THPK(X3,ISGN,NKH,NON) COMMON UP(666),VP(666),WP(666) COMMON /PEAKS/ NN,NPIC,DM,XMAX(3),AX(4,200) COMMON /AAPMP/ IAPA,IHAR,NHAR,MC1,NHV COMMON /TAPE/ NOSET,PARA(6) COMMON /TRANN/ TL(3,4),TS(3,24),FS(3,3,24),N1,N2,N3,MLAT DIMENSION X1(196),Y1(196),Z1(196),X3(3),U2(3) DIMENSION U(1000),V(1000),W(1000) ISGN=0 CALL EQPO(X3(1),X3(2),X3(3),X1,Y1,Z1,NEQ,1) NHK=0 DO 360 I=1,NHV DO 350 J=1,NEQ C GENERATE PATTERSON PEAKS (NON=0:HARKER PEAK; 1:NON-HARKER PEAK) IF (NON.EQ.1) GO TO 100 IF (J.EQ.1) GO TO 350 U2(1)=AMOD((X1(1)-X1(J))+10.0,1.0) U2(2)=AMOD((Y1(1)-Y1(J))+10.0,1.0) U2(3)=AMOD((Z1(1)-Z1(J))+10.0,1.0) GO TO 200 100 U2(1)=AMOD((AX(1,I)-X1(J))+10.0,1.0) U2(2)=AMOD((AX(2,I)-Y1(J))+10.0,1.0) U2(3)=AMOD((AX(3,I)-Z1(J))+10.0,1.0) 200 D1=AMOD(U2(1)+0.5,1.0)-0.5 D2=AMOD(U2(2)+0.5,1.0)-0.5 D3=AMOD(U2(3)+0.5,1.0)-0.5 IF (DIS(D1,D2,D3).LE.0.35) GO TO 350 NHK=NHK+1 U(NHK)=U2(1) V(NHK)=U2(2) W(NHK)=U2(3) 350 CONTINUE 360 CONTINUE DO 410 I=1,NHK J=NHK-I+1 IF (MLAT.EQ.1) GO TO 390 DO 370 K=2,MLAT D1=AMOD(U(J)-TL(1,K)+10.5,1.0)-0.5 D2=AMOD(V(J)-TL(2,K)+10.5,1.0)-0.5 D3=AMOD(W(J)-TL(3,K)+10.5,1.0)-0.5 IF (DIS(D1,D2,D3).LE.0.35) GO TO 380 370 CONTINUE GO TO 390 380 U(J)=1000.0 GO TO 410 390 IF (I.EQ.NHK) GO TO 410 K=J-1 C ELIMINATE DUPLICATE PEAKS DO 400 L=1,K D1=AMOD(U(J)-U(L)+10.5,1.0)-0.5 D2=AMOD(V(J)-V(L)+10.5,1.0)-0.5 D3=AMOD(W(J)-W(L)+10.5,1.0)-0.5 IF (DIS(D1,D2,D3).GT.0.75) GO TO 400 U(J)=1000.0 GO TO 410 400 CONTINUE 410 CONTINUE NKH=0 DO 550 I=1,NHK IF (U(I).GT.1.5) GO TO 550 NKH=NKH+1 UP(NKH)=U(I) VP(NKH)=V(I) WP(NKH)=W(I) 550 CONTINUE IF (NKH.GT.0) RETURN ISGN=1 RETURN END C ------------------------------------------------------------------- SUBROUTINE CHECKP(SD,X3,NPAT,NHK,NATOM,NAT,ISGN,NEQ) COMMON UP(666),VP(666),WP(666),EX(4000),EY(4000),EZ(4000), 1 CX(4000),CY(4000),CZ(4000),PW(4002) COMMON /PEAKS/ NN,NPIC,DM,XMAX(3),AX(4,400),NEP(400) COMMON /TAPE/ NOSET,PARA(6) DIMENSION X3(3),DIF(101) DATA DIF/.3989,.3988,.3987,.3986,.3985,.3984,.3981,.3978,.3975, 1 .3972,.3970,.3965,.3960,.3955,.3950,.3945,.3938,.3931,.3924, 2 .3917,.3910,.3901,.3892,.3883,.3874,.3867,.3856,.3845,.3834, 3 .3823,.3814,.3802,.3790,.3778,.3766,.3752,.3738,.3724,.3710, 4 .3696,.3683,.3668,.3652,.3636,.3621,.3605,.3588,.3571,.3554, 5 .3537,.3521,.3503,.3485,.3466,.3447,.3429,.3410,.3391,.3371, 6 .3351,.3332,.3311,.3290,.3270,.3250,.3230,.3208,.3186,.3164, 7 .3143,.3123,.3100,.3077,.3055,.3033,.3011,.2988,.2965,.2942, 8 .2919,.2897,.2874,.2850,.2826,.2803,.2780,.2757,.2733,.2709, 9 .2685,.2661,.2637,.2613,.2589,.2565,.2541,.2516,.2492,.2468, 9 .2444,.2420/ IF (ISGN.EQ.1) GO TO 400 C NOW CHECKING SOLUTIONS M0=0 WT=0.0 DO 300 J=1,NHK DO 100 K=1,NPAT D1=AMOD(CX(K)-UP(J)+10.5,1.0)-0.5 D2=AMOD(CY(K)-VP(J)+10.5,1.0)-0.5 D3=AMOD(CZ(K)-WP(J)+10.5,1.0)-0.5 DDD=DIS(D1,D2,D3) IF (DDD.GT.SD) GO TO 100 IDIF=MIN0(INT(DDD*100.0+1.5),100) WT=WT+PW(K)*DIF(IDIF)*2.5 M0=M0+1 GO TO 300 100 CONTINUE 300 CONTINUE IF (NHK.LE.M0) GO TO 500 ISGN=1 400 NATOM=NATOM-1 NAT=NAT-NEQ RETURN 500 AX(1,NATOM)=X3(1) AX(2,NATOM)=X3(2) AX(3,NATOM)=X3(3) AX(4,NATOM)=WT/NHK RETURN END C ------------------------------------------------------------------- FUNCTION DIS(D1,D2,D3) COMMON /TAPE/ NOSET,PARA(6),NEQV,NCENT,LATT COMMON /CONST/ NEX,KUSER1,DTOR,NP(3),ALPHA,BETA,GAMA DIS=SQRT(D1*D1*PARA(1)*PARA(1)+D2*D2*PARA(2)*PARA(2)+D3*D3*PARA(3) 1 *PARA(3)+2.0*D1*D2* PARA(1)*PARA(2)*COS(GAMA)+2.0*D1*D3*PARA(1) 2 *PARA(3)*COS(BETA)+2.0*D2*D3*PARA(2)*PARA(3)*COS(ALPHA)) RETURN END C-------------------------------------------------------------------- C PICK UP SINGLE ATOM FROM THE LIST OF ATOM WITH PSUDO-CENTRE SUBROUTINE PICKAM COMMON /PERIF/ TWOPI,VECT(8,3) COMMON /PEAKS/ NN1,NAT,DM,XMAX(3),AX(4,400) DIMENSION X1(196),Y1(196),Z1(196) DO 1000 I=2,NAT IF (AX(4,I).GT.99999.9) GO TO 1000 X=AMOD(VECT(1,1)-AX(1,I)+10.0,1.0) Y=AMOD(VECT(1,2)-AX(2,I)+10.0,1.0) Z=AMOD(VECT(1,3)-AX(3,I)+10.0,1.0) CALL EQPO(X,Y,Z,X1,Y1,Z1,NEQ,1) DO 800 K=I,NAT IF (AX(4,K).GT.99999.9) GO TO 800 DO 500 J=1,NEQ DELTAX=ABS(AMOD(AX(1,K)-X1(J)-VECT(1,1)+10.5,1.0)-0.5) DELTAY=ABS(AMOD(AX(2,K)-Y1(J)-VECT(1,2)+10.5,1.0)-0.5) DELTAZ=ABS(AMOD(AX(3,K)-Z1(J)-VECT(1,3)+10.5,1.0)-0.5) IF (DIS(DELTAX,DELTAY,DELTAZ).LE.0.75) GO TO 600 500 CONTINUE GO TO 800 600 AX(4,K)=100000.0 IF (K-I.EQ.1) AX(4,I)=100000.0 800 CONTINUE 1000 CONTINUE NUMB=NAT NAT=0 DO 1200 I=1,NUMB IF (AX(4,I).GT.99999.9) GO TO 1200 NAT=NAT+1 DO 1100 J=1,4 1100 AX(J,NAT)=AX(J,I) 1200 CONTINUE RETURN END ************************************************************************ * * * SSSSS EEEEEEE A RRRRRR CCCCC H H * * S S E A A R R C C H H * * S E A A R R C H H * * SSSSS EEEEEE A A RRRRRR C HHHHHHH * * S E AAAAAAA R R C H H * * S S E A A R R C C H H * * SSSSS EEEEEEE A A R R CCCCC H H * * * * A MODIFICATION OF THE PROGRAM SEARCH FROM MULTAN-80 * * VERSON 1998 * ************************************************************************ SUBROUTINE SEARCH4 C INCLUDE 'FLIB.FD' COMMON ISYM(100),INBOND(1000),IFRAG(400),ICON(400), 1 IBOND(2000),JFRAG(400),JCON(400),JBOND(2000),IUSE(400), 2 IONA(6,400),IONP(6,400),MO(400),MU(400),NO(400),NU(400), 3 KEYST(400),LW(400),LR(400),LX(400),JK(400),IK(400),KEY(400), 4 IPL(400),CAN(400),CON(400),LL(400),IA(6,400),LS(400),DUM(14400) COMMON /ATOMS/ X(4,400) COMMON /CONST/ DTOR, ANGMIN, ANGMAX, DMIN, 1 DMAX,DMUT,DM,DFRG,NSYM,NUMSET,NATM,NAT,METAL COMMON /MISC/ ITLE(80),CELL(6),T(3,3),DXMAX(3),MCON,IWT,FOM COMMON /CENT/ TL(3,4),TS(3,24),FS(3,3,24),MLAT,NEQV COMMON /SIZE/ KFRAG(20),NFRAG,LFRAG(20),MFRAG,NOFRAG,NN,MFRN CHARACTER ITLE,MATO(80) DIMENSION MNUM(40),MNOLL(40) DIMENSION XA(3,400),XB(4,400),IS(3,3,24), NAFRG(5), KMATCH(20) EQUIVALENCE (IONA(1,1),XA(1,1)),(IONP(1,1),XB(1,1)) C PRELIMINARY SECTION - SET UP ALL PROGRAM PARAMETERS C KUSER1 = MAXIMUM NUMBER OF PEAKS TO BE FOUND + 20, ALSO MAXIMUM C NUMBER OF PEAKS FOR INTERPRETATION AND DIMENSION OF SEVERAL ARRAYS KUSER1 = 400 C IWT RELATIVE WEIGHT OF IDENTIFIED ATOMS TO UNIDENTIFIED IWT = 2 MMM=0 rewind (38) c CALL CCPDPN(10,'SEARKW.TM','UNKNOWN','F',80,0) rewind (8) c CALL CCPDPN(8,'SAPIPKS','UNKNOWN','F',80,0) c OPEN(UNIT=10,FILE='SEARKW.TM',FORM='FORMATTED',STATUS='UNKNOWN') c OPEN(UNIT=6,FILE='SEARCH.OUT',FORM='FORMATTED',STATUS='UNKNOWN') c OPEN(UNIT=8,FILE='SAPI98.PKS',FORM='FORMATTED',STATUS='UNKNOWN') C READ DATA FROM CONTROL FILE GENERATED BY 'PREPARE' READ (38,200) NA,MFRN,NPC,METAL,NOJOIN,IAPA READ (38,300) ANGMIN,ANGMAX,DMIN,DMAX,DMUT,DM,DFRG,NK,ANAT 200 FORMAT(/6I6) 300 FORMAT(/2F7.2,5F8.4,I4,F8.2) C INPUT DATA FROM FFT FILE rewind (1) c CALL CCPDPN(1,'SAPIMAP','UNKNOWN','U',80,0) c OPEN(UNIT=1,FILE='SAPI98.MAP',FORM='UNFORMATTED',STATUS='UNKNOWN') READ (1) ITLE,NUMSET,CELL,NEQV,NCENT,LATT,NATM,TS,IS IF (NUMSET.LT.0) GO TO 2000 WRITE (6,340) ITLE,NUMSET,NATM, NA, METAL 340 FORMAT(1X, 1 'PEAK SEARCH AND INTERPRETATION',27X,'VERSION 1998', 2 //80A1//62X,7HSET NO.,I4//25X,30HNUMBER OF ATOMS TO BE FOUND IS, 3 I6/25X,35HNUMBER OF ATOMIC POSITIONS INPUT IS,I6 4 /17X,'NUMBER OF IONIC ATOMS IN ASYMMETRIC UNIT IS',I6) DO 310 L=1,NK READ (38,320) MATO(L),MATO(L+40),MNUM(L),MNOLL(L) 310 CONTINUE 320 FORMAT(2A1,2I6) READ (8,350) NAT 350 FORMAT(I4) DO 360 I=1,NAT READ (8,370) (X(J,I),J=1,4) 360 CONTINUE 370 FORMAT(11X,3F10.6,3X,F7.0) WRITE (6,740) NAT 740 FORMAT(/25X,35HNUMBER OF PEAKS TO BE CONSIDERED IS,I6) WRITE (6,820) DMIN, DMAX, ANGMIN, ANGMAX, DMUT 820 FORMAT(/31X,24H STEREOCHEMICAL CRITERIA/27X,'MINIMUM BONDING ', 1 'DISTANCE =',F6.2/27X,27HMAXIMUM BONDING DISTANCE =,F6.2/33X, 2 21HMINIMUM BOND ANGLE =,F6.1/33X,21HMAXIMUM BOND ANGLE =,F6.1/ 3 /16X,50HINTERATOMIC DISTANCES ARE OUTPUT WHEN LESS THAN,F6.2) IF (MFRN .LE. 0) WRITE (6,830) 830 FORMAT(/28X,'NO BOND SEQUENCES HAVE BEEN INPUT') C HALVE Y-AXIS BY C.OF.S. OR LATTICE TYPE IF POSSIBLE IHALF=0 IF (NCENT.EQ.1) IHALF=-1 IF (IHALF.NE.0) GO TO 888 GO TO (888,886,888,886,886,886,888), LATT 886 IHALF = 1 888 CALL CENTRE4 (1,1) C EXPAND TO FULL SPACE GROUP SYMMETRY C PUT CENTRING TRANSLATIONS IN TL(I,J) GO TO (940,890,890,890,890,910,920),LATT 890 CALL CENTRE4(2,LATT) GO TO 940 910 CALL CENTRE4(2,2) CALL CENTRE4(3,3) CALL CENTRE4(4,4) GO TO 940 920 CALL CENTRE4(2,6) CALL CENTRE4(3,7) 940 DO 1000 I=1,NEQV DO 970 J=1,3 DO 960 K=1,3 FS(K,J,I)=FLOAT(IS(K,J,I)) 960 CONTINUE 970 CONTINUE IF (I.EQ.1.OR.IHALF.NE.0) GO TO 1000 C HALVE Y-AXIS BY SYMMETRY OP. IF POSSIBLE DO 980 K=1,3 IF (IS(K,K,I).EQ.0) GO TO 1000 DO 975 J=1.3 IF(J.NE.K.AND.IS(J,K,I).NE.0) GO TO 1000 975 CONTINUE 980 CONTINUE IF (IS(2,2,I).EQ.(-1).AND.ABS(TS(2,I)).LT.1E-6) IHALF=-1 IF (IS(2,2,I).EQ.1.AND.ABS(TS(2,I)-0.5).LT.1E-6) IHALF=1 1000 CONTINUE NSYM=NEQV*(NCENT+1)*MLAT C SET UP CONSTANTS DTOR = 4.0 * ATAN(1.0) / 180.0 ANGMIN=COS(DTOR*ANGMIN) ANGMAX=COS(DTOR*ANGMAX) DMIN=DMIN*DMIN DMAX=DMAX*DMAX DMUT = DMUT * DMUT CA=COS(DTOR*CELL(4)) CB=COS(DTOR*CELL(5)) CC=COS(DTOR*CELL(6)) V=CELL(1)*CELL(2)*CELL(3)*SQRT(1.0-CA*CA-CB*CB-CC*CC+2.0*CA*CB*CC) DXMAX(1)=DM*CELL(2)*CELL(3)*SIN(DTOR*CELL(4))/V DXMAX(2)=DM*CELL(3)*CELL(1)*SIN(DTOR*CELL(5))/V DXMAX(3)=DM*CELL(1)*CELL(2)*SIN(DTOR*CELL(6))/V DM=DM*DM C SET UP MATRIX TO CALCULATE DISTANCES AND ANGLES DO 1020 I=4,6 J=8/I K=15/I T(J,K)=COS(DTOR*CELL(I)) T(K,J)=T(J,K) 1020 CONTINUE DO 1060 I=1,3 T(I,I)=1.0 DO 1040 J=1,3 T(I,J)=T(I,J)*CELL(I)*CELL(J) 1040 CONTINUE 1060 CONTINUE C INPUT ADDITIONAL PEAK POSITIONS IF DESIRED IF (NA.LE.0) GO TO 1140 NS=NAT+1 NAT=NAT+NA DO 1120 I=NS,NAT READ (38,1110) (X(J,I),J=1,3) 1110 FORMAT(1X,3F10.5) X(4,I)=10000.0 1120 CONTINUE C SORT PEAKS IN ORDER OF HEIGHT CALL SORT4(X,KUSER1,NAT,4) C ADJUST VALUES OF DXMAX FOR BOND LENGTH CALCULATION 1140 FACT=DFRG/SQRT(DM) DO 1160 I=1,3 DXMAX(I)=FACT*DXMAX(I) 1160 CONTINUE DFRG = DFRG * DFRG C INPUT USERS OWN MOLECULES FOR COMPARISON WITH THOSE C FRAGMENTS FOUND IN THE E-MAP IF (MFRN.GT.0) CALL INSEQ(NSEQ,NAFRG) C IDENTIFY SEPARATE CLUSTERS AND CALCULATE BOND LENGTHS AND ANGLES NN=0 NOFRAG=0 DO 1200 LOOP=1,KUSER1 IFRAG(LOOP)=0 IUSE(LOOP)=0 KEYST(LOOP)=0 1200 CONTINUE IF (NOJOIN.EQ.0) CALL CLSTRS(0) IF (NOJOIN.EQ.0.AND.MCON.GT.0) GO TO 1230 WRITE (6,1220) (I,(X(J,I),J=1,4),I=1,NAT) 1220 FORMAT(//1H ,22X,34HNOJOIN SPECIFIED OR NO BONDS FOUND// 1 1H ,31X,16HATOMIC POSITIONS//1H ,13X,5HPEAKS,7X,1HX,9X, 2 1HY,9X,1HZ,4X,6HHEIGHT/(1H ,12X,I4,2X,3F10.4,F8.0)) GO TO 1650 C FOR EACH CLUSTER OF MORE THAN 4 PEAKS WHICH HAS BEEN FOUND, C PLOT THE PEAKS IN PROJECTION, INTERPRET THEM IN TERMS OF BONDED C PEAKS AND COMPARE THEM WITH THOSE ATOMS INPUT BY THE USER 1230 DO 1600 NOFRG=1,NFRAG NOFRAG = NOFRG IF (KFRAG(NOFRAG) .LE. 4) GO TO 1600 IW = 0 NINT=1 FOM=0 1240 ISTART=0 C INTERPRETATION OF PEAKS BEGINS WITH PEAK ISTART C INTERPRET CLUSTER IN TERMS OF BONDED PEAKS AND ELIMINATE C PEAKS WHICH DO NOT FULFIL DISTANCE AND ANGLE CRITERIA 1300 CALL INTERP(ISTART,KUSER1,IW,FOMF) IF (ISTART.EQ.0) GO TO 1600 C ACCEPT INTERPRETATION IF FRAGMENT 1 CONTAINS MORE THAN 4 PEAKS. IF (ISTART .EQ. 1) GO TO 1400 IF (LFRAG(1) .LT. 5) GO TO 1240 C IF MORE THAN 1 FRAGMENT,SHUFFLE THEM AROUND 1400 IF (MFRAG.LE.1.OR.NN.EQ.0) GO TO 1450 CALL SHFFLE(MAXFRG) IF (MAXFRG.EQ.0) GO TO 1450 C REDO CLUSTER C INITIALISE ARRAYS FOR CLSTRS 1410 MC=0 M=1 DO 1418 I=1,NAT IF (IFRAG(I).NE.0.AND.IFRAG(I).NE.-1000) GO TO 1412 IUSE(I)=0 LW(I)=0 LR(I)=0 GO TO 1418 1412 IF (M.GT.MCON) GO TO 1418 II=IBOND(M)/4194304 IF (II-I) 1416,1414,1418 1414 MC=MC+1 IBOND(MC)=IBOND(M) 1416 M=M+1 GO TO 1412 1418 CONTINUE MCON=MC CALL CLSTRS(1) C REINTERPRET CLUSTER FOM=0.0 1420 CALL INTERP(ISTART,KUSER1,IW,FOMF) C ACCEPT INTERPRETATION IF FRAGMENT 1 CONTAINS MORE C THAN 4 PEAKS AND MORE THAN ONE NEW PEAK IS INCLUDED IN THE C INTERPRETATION AND THE SIZE OF THE FRAGMENTS IS SIGNIFICANT. IF (ISTART.EQ.0) GO TO 1600 IF (ISTART.EQ.1) GO TO 1450 IF (LFRAG(1).GE.5.AND.FOMF*FLOAT(IWT).GT.FOM) GO TO 1450 ISTART=0 GO TO 1420 1450 IF (MFRN.GT.0) CALL COMPAR4(NSEQ,NAFRG,KMATCH) C OUTPUT BONDING PATTERN AND IDENTIFIED ATOMS CALL OUTERP(ISTART,KMATCH,FOMF,MMM) IF (ISTART.GT.0) NINT=NINT+1 IF (NINT.GT.3) GO TO 1600 ISTART=0 GO TO 1420 1600 CONTINUE C OUTPUT INTERPEAK DISTANCES, PEAK HEIGHTS, AND BOND ANGLES CALL BONGLE C CREATE PEAK FILE FOR RECYCLING 1650 rewind (8) c CLOSE (8,STATUS='DELETE') c CALL CCPDPN(8,'SAPIPKS','UNKNOWN','F',80,0) c OPEN(8,FILE='SAPI98.PKS',FORM='FORMATTED',STATUS='UNKNOWN') c WRITE (8,1655) BTT c 1655 FORMAT(' B-FACTOR = ', F8.3) DO 1700 I=1,NAT WRITE (8,1800) (X(J,I),J=1,3),I 1700 CONTINUE 1800 FORMAT(1X,4H C,3F11.5,I5) 2000 CONTINUE CLOSE (38) close (1) c CLOSE (1) CLOSE (8) END C ------------------------------------------------------------------ C INPUT FRAGMENTS FOR COMPARISON WITH THOSE FOUND IN MAP SUBROUTINE INSEQ(NSEQ,NAFRG) COMMON ISYM(100),INBOND(1000),IFRAG(400),ICON(400), 1 IBOND(2000),JFRAG(400),JCON(400),JBOND(2000),IUSE(400), 2 IONA(6,400),IONP(6,400),MO(400),MU(400),NO(400),NU(400), 3 KEYST(400),LW(400),LR(400),LX(400),JK(400),IK(400),KEY(400), 4 IPL(400),CAN(400),CON(400),LL(400),IA(6,400),LS(400),DUM(14400) COMMON /CONST/ DTOR, ANGMIN, ANGMAX, DMIN, 1 DMAX,DMUT,DM,DFRG,NSYM,NUMSET,NATM,NAT,METAL DIMENSION ICH(12),LINE(80),LINX(60),IB(6),NAFRG(5) DATA ICH/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H ,1H// NSEQ=0 WRITE (6,50) 50 FORMAT(/1X,10X,23HMOLECULES INPUT BY USER) DO 90 J=1,400 DO 80 K=1,6 IONP(K,J)=0 80 CONTINUE 90 CONTINUE NAFRG(1)=0 NADR=0 NUM=0 ISL=0 IP=0 120 READ (38,130) LINE 130 FORMAT(80A1) DO 1000 I=1,80 DO 150 J=1,12 IF (ICH(J).EQ.LINE(I)) GO TO 160 150 CONTINUE CLOSE (1) CLOSE (6) STOP' --- ERROR in SEARCH ---' 160 IF (J.EQ.11) GO TO 170 IF (J.EQ.12) GO TO 180 NUM=10*NUM+J-1 GO TO 1000 170 IF (NUM.EQ.0) GO TO 1000 IF (IP.EQ.0) IAT=NUM IF (IP.GT.0) IB(IP)=NUM ISL=0 NUM=0 IP=IP+1 GO TO 1000 180 IF (IP.EQ.0) GO TO 400 IF (NUM.EQ.0) GO TO 190 IB(IP)=NUM IP=IP+1 NUM=0 190 IP=IP-1 IF (IP.EQ.0) GO TO 1000 DO 250 K=1,IP NAFRG(NSEQ+1)=MAX0(NAFRG(NSEQ+1),IAT,IB(K)) L=0 210 L=L+1 IF (IONP(L,IAT).EQ.IB(K)) GO TO 250 IF (IONP(L,IAT).GT.0) GO TO 210 IONP(L,IAT)=IB(K) IX=IB(K) L=0 220 L=L+1 IF (IONP(L,IX).GT.0) GO TO 220 IONP(L,IX)=IAT 250 CONTINUE IP=0 GO TO 1000 400 IF (ISL.EQ.(-1)) RETURN ISL=-1 NSEQ=NSEQ+1 N=NAFRG(NSEQ) NX=-29 WRITE (6,720) NSEQ,N 720 FORMAT(/1X,10X,15HFRAGMENT NUMBER,I4,5X,17HNUMBER OF ATOMS =,I4) 730 NX=NX+30 NP=MIN0(N,NX+29) WRITE (6,740) (J,J=NX,NP) 740 FORMAT(/1X,5HATOMS,5X,30I3) DO 780 K=1,6 L=0 LNO=0 DO 750 J=1,60 LINX(J)=ICH(11) 750 CONTINUE DO 760 J=NX,NP L=L+2 IF (IONP(K,J).EQ.0) GO TO 760 LNO=1 II=IONP(K,J) JJ=II/10 IF (JJ.GT.0) LINX(L-1)=ICH(JJ+1) JJ=II-10*JJ LINX(L)=ICH(JJ+1) IONP(K,J)=0 IF (II.LT.J) GO TO 760 NADR=NADR+1 INBOND(NADR)=512*J+II 760 CONTINUE IF (LNO.EQ.0) GO TO 790 WRITE (6,770) (LINX(J),J=1,L) 770 FORMAT(1H ,8HBONDS TO,2X,30(1X,2A1)) 780 CONTINUE 790 IF (NP.LT.N) GO TO 730 NADR=NADR+1 INBOND(NADR)=-1000 NAFRG(NSEQ+1)=0 IF (NSEQ.GE.5) RETURN 1000 CONTINUE GO TO 120 END C ------------------------------------------------------------------ C IDENTIFY SEPARATE BONDED CLUSTERS AND SET UP BONDING ARRAY. C NPASS DETERMINES PATH THROUGH SUBROUTINE. C NPASS = 0 :SET UP ALL CLUSTERS ; NPASS =1 :REDO CLUSTER NOFRAG SUBROUTINE CLSTRS(NPASS) COMMON ISYM(100),INBOND(1000),IFRAG(400),ICON(400), 1 IBOND(2000),JFRAG(400),JCON(400),JBOND(2000),IUSE(400), 2 IONA(6,400),IONP(6,400),MO(400),MU(400),NO(400),NU(400), 3 KEYST(400),LW(400),LR(400),LX(400),JK(400),IK(400),KEY(400), 4 IPL(400),CAN(400),CON(400),LL(400),IA(6,400),LS(400),DUM(14400) COMMON /ATOMS/ X(4,400) COMMON /CONST/ DTOR, ANGMIN, ANGMAX, DMIN, 1 DMAX,DMUT,DM,DFRG,NSYM,NUMSET,NATM,NAT,METAL COMMON /MISC/ ITLE(80),CELL(6),T(3,3),DXMAX(3),MCON,IWT,FOM COMMON /SIZE/ KFRAG(20),NFRAG,LFRAG(20),MFRAG,NOFRAG,NN,MFRN CHARACTER ITLE DIMENSION IB(3), XS(3), X1(3), X2(3), BSTOR(3), XSTOR(3) ICHECK=0 IF (NPASS.EQ.0) GO TO 1000 ICHECK=1 C REDUCE ISYM ARRAY TO EXCLUDE NOFRAG BONDINGS NNN=0 DO 995 I=1,NN IF (ISYM(I)/250000.EQ.NOFRAG) GO TO 995 NNN=NNN+1 ISYM(NNN)=ISYM(I) 995 CONTINUE NN=NNN GO TO 1025 C CLEAR ARRAYS 1000 NN=0 MCON=0 DO 1020 I=1,NAT IFRAG(I)=0 ICON(I)=0 LW(I) = 0 LR(I) = 0 1020 CONTINUE C APPLY DISTANCE CRITERION TO PEAKS TO IDENTIFY SEPARATE CLUSTERS C PEAKS WITHIN DISTANCE DMAX ARE POSSIBLE BONDED PEAKS NFRAG=0 NOFRAG=0 1025 NATM1=NAT-1 C START A NEW CLUSTER AT ATOM II DO 1180 II=1,NATM1 IF (IFRAG(II).EQ.(-1000)) GO TO 1030 IF (ICHECK.EQ.1.OR.IFRAG(II).NE.0) GO TO 1180 NOFRAG=NOFRAG+1 NFRAG=NFRAG+1 1030 ICHECK=0 IFRAG(II)=NOFRAG C KOUNT RECORDS NUMBER OF PEAKS IN PRESENT CLUSTER. KOUNT=1 I=II IBEGIN=II IF (NPASS.EQ.1) IBEGIN=1 1040 DO 1140 J=IBEGIN,NAT C DO NOT CONSIDER PEAK PAIRS MORE THAN ONCE IF (IFRAG(J).LT.0.AND.IFRAG(J).NE.(-1000)) GO TO 1140 JMOVE = 0 KSYM=0 DO 1120 K=1,NSYM C OMIT THE IDENTITY OPERATION WHEN I & J ARE THE SAME IF (I.EQ.J.AND.K.EQ.1) GO TO 1120 C CALC K'TH SYMM POSITION OF J'TH PEAK & MOVE AS CLOSE C TO I'TH PEAK AS POSSIBLE BY LATTICE TRANSLATIONS IF (JSYMM(I,J,K,IB,XS,X1).NE.0) GO TO 1120 C CALCULATE DISTANCE BETWEEN PEAKS I & J DIST=QUAD4(X1,X1,T) IF (DIST.GT.DFRG) GO TO 1120 C PEAK J IS CLOSE TO CLUSTER NOFRAG LR(J)=1 C DO NOT CONSIDER PEAKS OUTSIDE BONDING DISTANCE C OR PEAKS LYING ON SYMMETRY ELEMENTS IF (DIST.GT.DMAX) GO TO 1120 IF (DIST.LT.0.04) GO TO 1120 C PEAKS I & J ARE WITHIN BONDING DISTANCE-ADD TO CLUSTER IF (IABS(IFRAG(J)).EQ.NOFRAG) GO TO 1080 IF (IFRAG(J).EQ.(-1000)) GO TO 1060 C PEAK J CAN BE MOVED, SO MOVE IT & RECORD SYMM. OP. JMOVE=1 KSYM=K DO 1050 L=1,3 XSTOR(L)=XS(L) BSTOR(L)=FLOAT(IB(L)-5) 1050 CONTINUE C ADD J TO CLUSTER 1060 IFRAG(J)=NOFRAG KOUNT=KOUNT+1 C IF PEAK MOVED, ADD TO BONDING ARRAY IF (KSYM.EQ.K) GO TO 1100 1080 JBND=100000*IB(1)+10000*IB(2)+1000*IB(3)+K IF (JBND.EQ.555001) GO TO 1100 C CLUSTER NOFRAG BONDS TO ITSELF THROUGH I & J - RECORD IN ISYM NN=NN+1 IF (I.LT.J) ISYM(NN)=250000*NOFRAG+500*I+J IF (I.GE.J) ISYM(NN)=250000*NOFRAG+500*J+I GO TO 1120 1100 IF (I.EQ.J) GO TO 1120 IDIST=1000.0*SQRT(DIST)+0.5 MCON=MCON+1 IBOND(MCON)=(512*I+J)*8192+IDIST MCON=MCON+1 IBOND(MCON)=(512*J+I)*8192+IDIST 1120 CONTINUE IF (JMOVE .EQ. 0) GO TO 1140 DO 1125 L=1,3 X(L,J) = XSTOR(L) 1125 CONTINUE C IF ONE PEAK IN A FRAGMENT MOVES,MOVE ALL THE REST IF (NPASS.NE.1.OR.JFRAG(J).EQ.0) GO TO 1140 DO 1135 LOOP=1,NAT IF (LOOP.EQ.J) GO TO 1135 IF (IFRAG(LOOP).NE.0) GO TO 1135 IF (JFRAG(LOOP).NE.JFRAG(J)) GO TO 1135 CALL OPER4(KSYM,XS,X(1,LOOP),X(2,LOOP),X(3,LOOP)) DO 1130 L=1,3 X(L,LOOP)=XS(L) 1130 CONTINUE 1135 CONTINUE 1140 CONTINUE C PEAK I HAS BEEN COMPLETELY DEALT WITH IFRAG(I)=-IFRAG(I) C CHOOSE NEXT PEAK IN CLUSTER DO 1160 I=1,NAT IF (IFRAG(I).EQ.NOFRAG) GO TO 1040 1160 CONTINUE C CHECK FOR CLOSE APPROACHES BETWEEN CLUSTERS IF (KOUNT.EQ.1) GO TO 1179 KFRAG(NOFRAG)=KOUNT GO TO 1180 C SINGLE PEAKS ARE GIVEN A CLUSTER NUMBER OF ZERO 1179 IFRAG(II)=0 NFRAG=NFRAG-1 NOFRAG=NOFRAG-1 1180 CONTINUE DO 1240 I=1,NAT IFRAG(I)=IABS(IFRAG(I)) 1240 CONTINUE C PUT ENTRIES IN IBOND ARRAY IN ORDER OF PEAK HEIGHT IF (MCON.GT.0) CALL ISORT(IBOND,MCON) RETURN END C ------------------------------------------------------------------ C INTERPRET CLUSTER IN TERMS OF BONDED PEAKS AND ELIMINATE C PEAKS WHICH DO NOT FULFIL DISTANCE AND ANGLE CRITERIA SUBROUTINE INTERP(ISTART,KUSER1,IW,FOMF) COMMON ISYM(100),INBOND(1000),IFRAG(400),ICON(400), 1 IBOND(2000),JFRAG(400),JCON(400),JBOND(2000),IUSE(400), 2 IONA(6,400),IONP(6,400),MO(400),MU(400),NO(400),NU(400), 3 KEYST(400),LW(400),LR(400),LX(400),JK(400),IK(400),KEY(400), 4 IPL(400),CAN(400),CON(400),LL(400),IA(6,400),LS(400),DUM(14400) COMMON /ATOMS/ X(4,400) COMMON /CONST/ DTOR, ANGMIN, ANGMAX, DMIN, 1 DMAX,DMUT,DM,DFRG,NSYM,NUMSET,NATM,NAT,METAL COMMON /MISC/ ITLE(80),CELL(6),T(3,3),DXMAX(3),MCON,IWT,FOM COMMON /SIZE/ KFRAG(20),NFRAG,LFRAG(20),MFRAG,NOFRAG,NN,MFRN CHARACTER ITLE DIMENSION X1(3),X2(3) C COPY CLUSTER INTO NEW ARRAY M=1 J=0 DO 980 I=1,NAT JCON(I)=0 JFRAG(I)=0 ICON(I)=J IF (IFRAG(I) .NE. NOFRAG) GO TO 980 IF (ISTART.EQ.0.AND.IUSE(I).EQ.0) ISTART=I IF (ISTART.LE.METAL) ISTART=0 950 IF (M.GT.MCON) GO TO 980 II=IBOND(M)/4194304 IF (II-I) 970,960,980 960 JCON(I)=JCON(I)+1 J=J+1 JBOND(J)=MOD(IBOND(M),4194304) IF (I.EQ.ISTART.AND.JBOND(J)/8192.LE.METAL) ISTART = 0 970 M=M+1 GO TO 950 980 CONTINUE ICON(NAT+1)=J IF (ISTART.EQ.0) RETURN MFRAG=0 IDMIN=1000.0*SQRT(DMIN)+0.5 C START INTERPRETATION OF NEW SET OF PEAKS AT PEAK II II=ISTART IF (METAL.EQ.0) GO TO 1080 DO 1020 I=1,METAL IF (IFRAG(I).NE.NOFRAG) GO TO 1020 JCON(I)=0 KS=ICON(I)+1 KL=ICON(I+1) IF (KS.GT.KL) GO TO 1010 DO 1000 J=KS,KL L=JBOND(J)/8192 CALL ELIM(L,JFRAG(L),JCON,JBOND,ICON,KUSER1) 1000 CONTINUE 1010 CALL ELIM(I,JFRAG(I),JCON,JBOND,ICON,KUSER1) 1020 CONTINUE GO TO 1080 1040 II=0 1060 II=II+1 IF (II.GT.NAT) GO TO 1620 IF (JFRAG(II).NE.0) GO TO 1060 IF (JCON(II) .LE. 0) GO TO 1060 1080 MFRAG=MFRAG+1 JFRAG(II)=MFRAG LFRAG(MFRAG)=1 I=II 1100 KS=ICON(I)+1 KL=ICON(I+1) C APPLY MINIMUM DISTANCE CRITERION TO PEAKS AROUND THE ITH PEAK DO 1140 J=KS,KL IF (JBOND(J).EQ.0) GO TO 1140 IDIST=MOD(JBOND(J),8192) IF (IDIST.GE.IDMIN) GO TO 1140 L=JBOND(J)/8192 C PEAKS I AND L ARE TOO CLOSE - ELIMINATE L CALL ELIM(L,JFRAG(L),JCON,JBOND,ICON,KUSER1) 1140 CONTINUE C APPLY ANGLE CRITERIA TO PEAKS AROUND THE ITH PEAK IF (KS.EQ.KL) GO TO 1480 C CONSIDER THE ANGLES FRAGMENT - I - ANYTHING DO 1360 J=KS,KL IF (JBOND(J).EQ.0) GO TO 1360 JJ=JBOND(J)/8192 C FIND A FRAGMENT PEAK IF (IABS(JFRAG(JJ)).NE.MFRAG) GO TO 1360 C SET UP VECTOR JJ - I FOR ANGLE CALCULATION DO 1300 L=1,3 X1(L) = X(L,JJ) - X(L,I) 1300 CONTINUE VEC1=0.001*FLOAT(MOD(JBOND(J),8192)) DO 1340 K=KS,KL IF (JBOND(K).EQ.0) GO TO 1340 KK=JBOND(K)/8192 IF (JJ.EQ.KK) GO TO 1340 C CALCULATE COSINE OF ANGLE BETWEEN PEAKS JJ - I - KK DO 1320 L=1,3 X2(L)=X(L,KK)-X(L,I) 1320 CONTINUE VEC2=0.001*FLOAT(MOD(JBOND(K),8192)) COSA=QUAD4(X1,X2,T)/(VEC1*VEC2) C IF ANGLE IS WITHIN LIMITS CONTINUE TESTING IF (COSA.GE.ANGMAX.AND.COSA.LE.ANGMIN) GO TO 1340 C ELIMINATE KK IF IT IS NOT IN THE FRAGMENT IF (IABS(JFRAG(KK)).NE.MFRAG) GO TO 1330 LFRAG(MFRAG) = LFRAG(MFRAG) - 1 C KK IS IN THE FRAGMENT - HAS IT ALREADY BEEN CONSIDERED IF (JFRAG(KK).GT.0) GO TO 1330 C KK HAS ALREADY BEEN FULLY CONSIDERED FOR THE FRAGMENT-ELIMINATE I CALL ELIM(I,JFRAG(I),JCON,JBOND,ICON,KUSER1) GO TO 1500 1330 CALL ELIM(KK,JFRAG(KK),JCON,JBOND,ICON,KUSER1) 1340 CONTINUE 1360 CONTINUE C CONSIDER THE ANGLES NONFRAG - I - NONFRAG KLM1=KL-1 DO 1460 J=KS,KLM1 IF (JBOND(J).EQ.0) GO TO 1460 JJ=JBOND(J)/8192 C FIND A NON-FRAGMENT PEAK IF (IABS(JFRAG(JJ)).EQ.MFRAG) GO TO 1460 C ADD PEAK TO FRAGMENT JFRAG(JJ)=MFRAG LFRAG(MFRAG)=LFRAG(MFRAG)+1 C SET UP VECTOR JJ - I FOR ANGLE CALCULATION DO 1400 L=1,3 X1(L)=X(L,JJ)-X(L,I) 1400 CONTINUE VEC1=0.001*FLOAT(MOD(JBOND(J),8192)) JP1=J+1 DO 1440 K=JP1,KL IF (JBOND(K).EQ.0) GO TO 1440 KK = JBOND(K)/8192 C FIND A NON-FRAGMENT PEAK IF (IABS(JFRAG(KK)).EQ.MFRAG) GO TO 1440 C CALCULATE COSINE OF ANGLE BETWEEN PEAKS JJ - I - KK DO 1420 L=1,3 X2(L)=X(L,KK)-X(L,I) 1420 CONTINUE VEC2=0.001*FLOAT(MOD(JBOND(K),8192)) COSA=QUAD4(X1,X2,T)/(VEC1*VEC2) C IF ANGLE IS OUTSIDE LIMITS ELIMINATE KK IF (COSA.LT.ANGMAX.OR.COSA.GT.ANGMIN) 1 CALL ELIM(KK,JFRAG(KK),JCON,JBOND,ICON,KUSER1) 1440 CONTINUE 1460 CONTINUE C SEE IF LAST PEAK CAN JOIN FRAGMENT 1480 JJ=JBOND(KL)/8192 IF (JCON(JJ).LE.0.OR.JFRAG(JJ).NE.0) GO TO 1490 JFRAG(JJ)=MFRAG LFRAG(MFRAG)=LFRAG(MFRAG)+1 C PEAK I HAS NOW BEEN FULLY CONSIDERED 1490 JFRAG(I)=-JFRAG(I) C FIND LARGEST PEAK IN CLUSTER NOT YET DEALT WITH 1500 DO 1520 I=1,NAT IF (JFRAG(I).EQ.MFRAG) GO TO 1100 1520 CONTINUE IF (LFRAG(MFRAG).GT.1) GO TO 1600 C SINGLE PEAKS ARE GIVEN A FRAGMENT NUMBER OF ZERO JFRAG(II)=0 MFRAG=MFRAG-1 1600 IF (II-ISTART)1060,1040,1060 C INTERPRETATION COMPLETE 1620 FOMF=0.0 KKK=0 DO 1640 I=1,NAT JFRAG(I)=IABS(JFRAG(I)) J=JFRAG(I) IF (J.EQ.0.OR.LFRAG(J).LT.4) GO TO 1640 FOMF=FOMF+ALOG10(FLOAT(LFRAG(J)))*X(4,I) IF (IUSE(I).EQ.0) KKK=1 1640 CONTINUE IF (KKK.EQ.0) FOMF=0.0 IF (IUSE(ISTART).EQ.0) IUSE(ISTART)=1 RETURN END C ------------------------------------------------------------------ C THIS ROUTINE SHUFFLES FRAGMENTS ACCORDING TO THE BONDINGS C STORED IN ISYM, ALTERING FRAGMENT NUMBER AS WELL SUBROUTINE SHFFLE(MAXFRG) COMMON ISYM(100),INBOND(1000),IFRAG(400),ICON(400), 1 IBOND(2000),JFRAG(400),JCON(400),JBOND(2000),IUSE(400), 2 IONA(6,400),IONP(6,400),MO(400),MU(400),NO(400),NU(400), 3 KEYST(400),LW(400),LR(400),LX(400),JK(400),IK(400),KEY(400), 4 IPL(400),CAN(400),CON(400),LL(400),IA(6,400),LS(400),DUM(14400) COMMON /ATOMS/ X(4,400) COMMON /CONST/ DTOR, ANGMIN, ANGMAX, DMIN, 1 DMAX,DMUT,DM,DFRG,NSYM,NUMSET,NATM,NAT,METAL COMMON /MISC/ ITLE(80),CELL(6),T(3,3),DXMAX(3),MCON,IWT,FOM COMMON /SIZE/ KFRAG(20),NFRAG,LFRAG(20),MFRAG,NOFRAG,NN,MFRN CHARACTER ITLE DIMENSION XTEMP(3),TN(3),IB(3),XS(3),X1(3) MAXFRG=0 C CONSIDER EACH SYMM. OP. IN TURN DO 700 K1=1,NN C OBTAIN PEAKS IN RELEVANT SYMM OPS AND CLUSTER ITEMP=ISYM(K1)/250000 IF (ITEMP.NE.NOFRAG) GO TO 700 I1=MOD(ISYM(K1),250000)/500 I2=MOD(ISYM(K1),500) C IF SAME FRAGMENT, DISREGARD SYMM. OP. IF (JFRAG(I1).EQ.JFRAG(I2)) GO TO 700 C DETERMINE WHICH FRAGMENT TO MOVE, AND OBTAIN CORRECT C SYMMETRY OPERATION TO DO SO,ACCOUNTING FOR SINGLE PEAKS. 100 JI1=JFRAG(I1) JI2=JFRAG(I2) IF (JI1.EQ.0) GO TO 150 IF (JI2.EQ.0) GO TO 200 IF (LFRAG(JI1).GE.LFRAG(JI2)) GO TO 200 150 IAT=I1 IOTHER=I2 GO TO 300 200 IAT=I2 IOTHER=I1 300 JIAT=JFRAG(IAT) JOTHER=JFRAG(IOTHER) C IDENTIFY ALL PEAKS IN FRAGMENT TO BE MOVED, AND MOVE THEM DO 345 K=1,NSYM IF (JSYMM(IOTHER,IAT,K,IB,XS,X1).NE.0) GO TO 345 IF (QUAD4(X1,X1,T).LE.DMAX) GO TO 347 345 CONTINUE 347 DO 350 L=1,3 X(L,IAT)=XS(L) TN(L)=FLOAT(IB(L)-5) 350 CONTINUE JFRAG(IAT)=JOTHER IF (JIAT.EQ.0) GO TO 520 DO 500 K2=1,NAT IF (JFRAG(K2).NE.JIAT) GO TO 500 CALL OPER4(K,XTEMP,X(1,K2),X(2,K2),X(3,K2)) DO 450 K5=1,3 X(K5,K2)=XTEMP(K5)+TN(K5) 450 CONTINUE JFRAG(K2)=JOTHER 500 CONTINUE C CORRECT LFRAG ARRAY LFRAG(JOTHER)=LFRAG(JOTHER)+LFRAG(JIAT) LFRAG(JIAT)=0 GO TO 550 520 LFRAG(JOTHER)=LFRAG(JOTHER)+1 550 IF (LFRAG(JOTHER).GT.MAXFRG) MAXFRG=LFRAG(JOTHER) C CLOSE UP LFRAG & JFRAG ARRAYS IF (JIAT.EQ.0) GO TO 700 MFRAG=MFRAG-1 DO 620 K7=1,MFRAG IF (LFRAG(K7).NE.0) GO TO 620 LFRAG(K7)=LFRAG(K7+1) LFRAG(K7+1)=0 620 CONTINUE DO 650 K8=1,NAT IF (JFRAG(K8).LT.JIAT) GO TO 650 JFRAG(K8)=JFRAG(K8)-1 650 CONTINUE 700 CONTINUE C RETURN IF NO SHUFFLING HAS TAKEN PLACE IF (MAXFRG.EQ.0) RETURN C PUTS IFRAG -VE FOR ALL PEAKS IN CLUSTERS OTHER THAN NOFRAG, C ZEROS IFRAG FOR MOVABLE PEAKS, AND PUTS IFRAG C EQUAL TO -1000 FOR THE LARGEST COMBINED FRAGMENT. DO 900 LOOP=1,MFRAG IF (LFRAG(LOOP).NE.MAXFRG) GO TO 900 GO TO 1000 900 CONTINUE 1000 JCOMB=LOOP DO 1300 LOOP=1,NAT IF (IFRAG(LOOP).EQ.NOFRAG) GO TO 1100 IFRAG(LOOP)=-IFRAG(LOOP) GO TO 1300 1100 IF (JFRAG(LOOP).EQ.JCOMB) GO TO 1200 IFRAG(LOOP)=0 GO TO 1300 1200 IFRAG(LOOP)=-1000 1300 CONTINUE RETURN END C ------------------------------------------------------------------ SUBROUTINE COMPAR4(NSEQ,NAFRG,KMATCH) COMMON ISYM(100),INBOND(1000),IFRAG(400),ICON(400), 1 IBOND(2000),JFRAG(400),JCON(400),JBOND(2000),IUSE(400), 2 IONA(6,400),IONP(6,400),MO(400),MU(400),NO(400),NU(400), 3 KEYST(400),LW(400),LR(400),LX(400),JK(400),IK(400),KEY(400), 4 IPL(400),CAN(400),CON(400),LL(400),IA(6,400),LS(400),DUM(14400) COMMON /CONST/ DTOR, ANGMIN, ANGMAX, DMIN, 1 DMAX,DMUT,DM,DFRG,NSYM,NUMSET,NATM,NAT,METAL COMMON /SIZE/ KFRAG(20),NFRAG,LFRAG(20),MFRAG,NOFRAG,NN,MFRN DIMENSION NAFRG(5), KMATCH(20) DO 2000 MOFRAG=1,MFRAG KMATCH(MOFRAG)=0 IF (LFRAG(MOFRAG).LT.5) GO TO 2000 M=0 DO 100 I=1,NAT NU(I)=0 IF (JFRAG(I).NE.MOFRAG) GO TO 100 M=M+1 NO(M)=I NU(I)=M 100 CONTINUE DO 150 I=1,NAT IF (NU(I).EQ.0) GO TO 150 KEYST(I)=0 M=NU(I) DO 130 J=1,6 IONP(J,M)=0 130 CONTINUE K=0 KS=ICON(I)+1 KL=ICON(I+1) DO 140 J=KS,KL MC=JBOND(J)/8192 IF (MC.LE.0) GO TO 140 K=K+1 IONP(K,M)=NU(MC) 140 CONTINUE 150 CONTINUE CALL CANON(M,MR) KM=0 DO 200 I=1,M K=NU(I) MU(K)=NO(I) LW(I)=LX(I) IF (I.LE.6.OR.I.LE.MR) KM=KM+LW(I) DO 190 J=1,6 IONA(J,I)=IONP(J,I) 190 CONTINUE 200 CONTINUE NADR=0 MSTOR=1 MERIT=1 DO 1800 NX=1,NSEQ N=NAFRG(NX) DO 350 I=1,N LL(I)=0 DO 340 J=1,6 IONP(J,I)=0 340 CONTINUE 350 CONTINUE 360 NADR=NADR+1 IF (INBOND(NADR).LT.(-999)) GO TO 370 I=INBOND(NADR)/512 J=MOD(INBOND(NADR),512) K=LL(I)+1 IONP(K,I)=J LL(I)=K K=LL(J)+1 IONP(K,J)=I LL(J)=K GO TO 360 370 CALL CANON(N,NR) KN=0 DO 410 I=1,N IF (I.LE.6.OR.I.LE.NR) KN=KN+LX(I) 410 CONTINUE IF (KN.GE.KM) CALL TELL(N,NR,M,MR,MERIT,1,IONA,IONP,LW) IF (KN.LT.KM) CALL TELL(M,MR,N,NR,MERIT,2,IONP,IONA,LX) IF (MERIT.LE.MSTOR) GO TO 1800 MSTOR=MERIT+1 DO 450 I=1,N K=NU(I) NO(K)=I 450 CONTINUE DO 500 I=1,NAT IF (JFRAG(I).EQ.MOFRAG) KEYST(I)=0 500 CONTINUE DO 1700 I=1,M IF (MO(I).EQ.0) GO TO 1700 K=MO(I) J=MU(I) KEYST(J)=NO(K) 1700 CONTINUE KMATCH(MOFRAG)=NX 1800 CONTINUE 2000 CONTINUE RETURN END C ------------------------------------------------------------------ SUBROUTINE OUTERP(ISTART,KMATCH,FOMF,MMM) COMMON ISYM(100),INBOND(1000),IFRAG(400),ICON(400), 1 IBOND(2000),JFRAG(400),JCON(400),JBOND(2000),IUSE(400), 2 IONA(6,400),IONP(6,400),MO(400),MU(400),NO(400),NU(400), 3 KEYST(400),LW(400),LR(400),LX(400),JK(400),IK(400),KEY(400), 4 IPL(400),CAN(400),CON(400),LL(400),IA(6,400),LS(400),DUM(14400) COMMON /ATOMS/ X(4,400) COMMON /CONST/ DTOR, ANGMIN, ANGMAX, DMIN, 1 DMAX,DMUT,DM,DFRG,NSYM,NUMSET,NATM,NAT,METAL COMMON /MISC/ ITLE(80),CELL(6),T(3,3),DXMAX(3),MCON,IWT,FOM COMMON /SIZE/ KFRAG(20),NFRAG,LFRAG(20),MFRAG,NOFRAG,NN,MFRN CHARACTER ITLE DIMENSION ICH(10),KMATCH(20),INMAT(7,400),IOUT(6) DATA IBL/1H /,ISK/1H*/,ICY/1HY/ DATA ICH/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/ C DECIDE IF SET IS WORTH PRINTING ISTART=-ISTART FOMM=0.0 DO 200 I=1,NAT J=JFRAG(I) IF (J.EQ.0.OR.LFRAG(J).LT.4.OR.KEYST(I).LE.0) GO TO 200 FOMM=FOMM+ALOG10(FLOAT(LFRAG(J)))*X(4,I)*FLOAT(IWT) 200 CONTINUE IDR=0 IF (FOMM.GT.FOMF) IDR=1 IF (FOM.GE.FOMM.AND.FOM.GE.FOMF) RETURN FOM=AMAX1(FOMM,FOMF) DO 240 I=1,NAT IF (IFRAG(I).NE.NOFRAG) GO TO 240 IUSE(I)=IABS(IUSE(I)) IF (JCON(I).LE.0) GO TO 240 J=JFRAG(I) IF (LFRAG(J).LT.4) GO TO 240 IF (IDR.EQ.0) IUSE(I)=-1 IF (IDR.EQ.1.AND.KEYST(I).GT.0) IUSE(I)=-1 240 CONTINUE ISTART=-ISTART WRITE (6,245) 245 FORMAT(//10X,58(1H-)) C OUTPUT FRAGMENT COMPARISON RESULTS IF (MFRN.EQ.0) GO TO 290 DO 270 K=1,MFRAG IF (LFRAG(K).LT.5) GO TO 270 NID=0 DO 250 I=1,NAT IF (JFRAG(I).NE.K.OR.KEYST(I).LE.0) GO TO 250 NID=NID+1 IONP(1,NID)=I IONP(2,NID)=KEYST(I) 250 CONTINUE IF (NID.GT.0) WRITE (6,260) NID,K,KMATCH(K),((IONP(I,J),I=1,2), 1 J=1,NID) 260 FORMAT(/2X,I5,3X,17HPEAKS OF FRAGMENT,I5,3X, 1 34HMATCH WITH ATOMS OF INPUT MOLECULE,I5/ 2 12X,24HPEAK-ATOM CORRESPONDENCE//(6(I6,2H -,I4))) 270 CONTINUE C DETERMINE RING STRUCTURE 290 DO 300 I=1,NAT IK(I)=JCON(I) IF (JCON(I).GT.0) LAST=I 300 CONTINUE 400 NST=0 DO 500 I=1,NAT IF (IK(I).NE.1) GO TO 500 NST=1 IK(I)=0 KS=ICON(I)+1 KL=ICON(I+1) DO 450 J=KS,KL K=JBOND(J)/8192 IF (K.LE.0) GO TO 450 IF (IK(K).GE.1) IK(K)=IK(K)-1 450 CONTINUE 500 CONTINUE IF (NST.EQ.1) GO TO 400 WRITE (6,650) NOFRAG,ISTART 650 FORMAT(//10X,25HINTERPRETATION OF CLUSTER,I3,' STARTING ', 1 'WITH PEAK NUMBER',I3) MMM=MMM+1 LMAX=0 M=0 NM=0 DO 1500 I=1,NAT IF (JCON(I).LE.0) GO TO 1500 M=M+1 NM=NM+1 LW(M+30)=I INMAT(1,NM)=I IF (M.EQ.13.OR.I.EQ.LAST) WRITE (6,700) (LW(K+30),K=1,M) 700 FORMAT(/1X,4HPEAK,8X,13I4) K=ICON(I) KL=ICON(I+1) DO 800 J=1,6 MX=M+30*(J-1) INMAT(J+1,NM)=0 C JKK(NM)=ICHRA LR(MX)=IBL LL(MX)=IBL LX(MX)=IBL 740 K=K+1 IF (K.GT.KL) GO TO 750 IF (JBOND(K).LE.0) GO TO 740 LMAX=MAX0(J,LMAX) JBS=JBOND(K)/8192 INMAT(J+1,NM)=JBS JJ=JBS/100 IF (JJ.GT.0) LR(MX)=ICH(JJ+1) JJ=JBS/10-JJ*10 IF (JBS.GE.10) LL(MX)=ICH(JJ+1) JJ=MOD(JBS,10) LX(MX)=ICH(JJ+1) 750 IF (LMAX.LT.J) GO TO 800 MJ=30*(J-1)+1 IF (M.EQ.13.OR.I.EQ.LAST) 1 WRITE (6,770) (LR(L),LL(L),LX(L),L=MJ,MX) 770 FORMAT(1H ,8HBONDS TO,4X,13(1X,3A1)) 800 CONTINUE LW(M)=JFRAG(I) JK(M)=IBL IF (IK(I).GE.2) JK(M)=ISK C IF (IK(I).GE.2) JKK(NM)=ICHRC IF (M.EQ.13.OR.I.EQ.LAST) WRITE (6,840) (JK(K),K=1,M) 840 FORMAT(1H ,4HRING,8X,13(3X,A1)) IF (M.EQ.13.OR.I.EQ.LAST) WRITE (6,850) (LW(K),K=1,M) 850 FORMAT(1H ,8HFRAGMENT,4X,13I4) IF (MFRN.LE.0) GO TO 1490 JK(M+30)=IBL IF (KEYST(I).GT.0) JK(M+30)=ICY IF (M.EQ.13.OR.I.EQ.LAST) WRITE (6,860) (JK(K+30),K=1,M) 860 FORMAT(1H ,7HMATCHED,5X,13(3X,A1)) 1490 IF (M.NE.13) GO TO 1500 M=0 LMAX=1 1500 CONTINUE DO 1540 I=1,NM ION=0 DO 1530 J=1,6 IF (INMAT(J+1,I).EQ.0) GOTO 1530 ION=ION+1 IOUT(ION)=INMAT(J+1,I) 1530 CONTINUE 1540 CONTINUE WRITE (6,1580) (LFRAG(I),I=1,MFRAG) 1580 FORMAT(/4X,33H NO. OF PEAKS IN EACH FRAGMENT,5X,12I4) RETURN END C ------------------------------------------------------------------ C CALCULATE AND OUTPUT PEAK POSITIONS,BOND LENGTHS,AND ANGLES. SUBROUTINE BONGLE COMMON ISYM(100),INBOND(1000),IFRAG(400),ICON(400), 1 IBOND(2000),JFRAG(400),JCON(400),JBOND(2000),IUSE(400), 2 IONA(6,400),IONP(6,400),MO(400),MU(400),NO(400),NU(400), 3 KEYST(400),LW(400),LR(400),LX(400),JK(400),IK(400),KEY(400), 4 IPL(400),CAN(400),CON(400),LL(400),IA(6,400),LS(400),DUM(14400) COMMON /ATOMS/ X(4,400) COMMON /CONST/ DTOR, ANGMIN, ANGMAX, DMIN, 1 DMAX,DMUT,DM,DFRG,NSYM,NUMSET,NATM,NAT,METAL COMMON /MISC/ ITLE(80),CELL(6),T(3,3),DXMAX(3),MCON,IWT,FOM COMMON /CENT/ TL(3,4),TS(3,24),FS(3,3,24),MLAT,NEQV COMMON /SIZE/ KFRAG(20),NFRAG,LFRAG(20),MFRAG,NOFRAG,NN,MFRN CHARACTER ITLE DIMENSION IB(3),XS(3),X1(3),X2(3),JFMT(20),ENIL1(4,4),LINE(30), 1 LINE1(4,6),ENIL(30),JBND(30),XSTOR(3),EENIL(400),JJBND(400) DATA JFMT(1)/4H( 1X/, JFMT(2)/4H,I6,/, JFMT(3)/3HI7,/, 1 JFMT(4)/4H 1X,/, JFMT(5)/3H3F8/, JFMT(6)/4H.4, /, 2 IBLANK/4H3X, /, IEND/4HI3) / C OUTPUT PEAK HEIGHTS, PEAK COORDINATES AND CLUSTER NUMBERS WRITE (6,900) ITLE 900 FORMAT(//10X,60(1H-)//80A1//28X,17HPEAK COORDINATES// 1 1X,7H PEAK,1X,6HHEIGHT,5X,1HX,7X,1HY,7X,1HZ,9X, 2 15H CLUSTER NUMBER/) DO 940 I=1,NAT ICON(I+1)=0 IFRAG(I)=IABS(IFRAG(I)) C N=MIN0(IFRAG(I)+1,15) N=MIN0(IFRAG(I)+1,11) DO 920 J=1,N JFMT(J+6)=IBLANK 920 CONTINUE JFMT(N+7)=IEND K=X(4,I)+0.5 WRITE (6,JFMT) I,K,(X(J,I),J=1,3),IFRAG(I) 940 CONTINUE N = MIN0(NFRAG, 10) WRITE (6,960) (KFRAG(I),I=1,N) IW=0 960 FORMAT(/2X,37HTOTAL NUMBER OF PEAKS IN EACH CLUSTER,6X,10I3) WRITE (6,1110) ITLE 1110 FORMAT(//10X,60(1H-)//80A1//26X, 1 28HTABLE OF INTERPEAK DISTANCES//1H ,2X,4HFROM,3X,7HTO DIST) ICON(1)=0 DO 1115 I=1,MCON II=IBOND(I)/4194304 ICON(II+1)=I 1115 CONTINUE DO 1260 I=1,NAT IF (ICON(I+1).EQ.0) ICON(I+1)=ICON(I) N=0 NM=0 JUMP=0 DO 1220 J=1,NAT IF (J.EQ.I) GO TO 1170 DO 1120 K=1,3 X1(K)=X(K,I)-X(K,J) IF (ABS(X1(K)).GT.DXMAX(K)) GO TO 1170 1120 CONTINUE DIST=QUAD4(X1,X1,T) IF (DIST.GT.DMUT) GO TO 1170 N=N+1 NM=NM+1 JBND(N)=J JJBND(NM)=J ENIL(N)=SQRT(DIST) EENIL(NM)=SQRT(DIST) 1170 IF (N.LT.6.AND.J.NE.NAT) GO TO 1220 IF (JUMP.EQ.0.AND.N.GT.0) WRITE (6,1190) I,(JBND(L),ENIL(L),L=1,N) IF (JUMP.NE.0.AND.N.GT.0) WRITE (6,1210) (JBND(L),ENIL(L),L=1,N) 1210 FORMAT(1H ,5X,6(I6,F5.2)) N=0 JUMP=1 1220 CONTINUE 1260 CONTINUE 1190 FORMAT(1H ,I5,6(I6,F5.2)) DMX=SQRT(DMAX) WRITE (6,1300) DMX 1300 FORMAT( //16X,'TABLE OF BOND ANGLES (IN DEGREES) AMONG PEAKS '/ 1 17X,'IN ABOVE TABLE CLOSER TOGETHER THAN',F5.2,3H(A)/) N=0 RTOD=1.0/DTOR DO 1500 I=1,NAT KS=ICON(I)+1 KL=ICON(I+1) IF (KS.GE.KL) GO TO 1500 KLM1=KL-1 DO 1490 J=KS,KLM1 V1=0.001*FLOAT(MOD(IBOND(J),8192)) IF (V1.GT.DMX.OR.V1.LT.0.2) GO TO 1490 JJ=IBOND(J)/8192 JJ=MOD(JJ,512) JP1=J+1 DO 1480 K=JP1,KL V2=0.001*FLOAT(MOD(IBOND(K),8192)) IF (V2.GT.DMX.OR.V2.LT.0.2) GO TO 1480 KK=IBOND(K)/8192 KK=MOD(KK,512) DO 1430 L=1,3 X1(L)=X(L,KK)-X(L,JJ) 1430 CONTINUE DIST=QUAD4(X1,X1,T) IF (DIST.LT.0.2) GO TO 1480 COSA=0.5*(V1*V1+V2*V2-DIST)/(V1*V2) SINA=SQRT(AMAX1(1.0-COSA*COSA,0.001)) N=N+1 LINE1(1,N)=JJ LINE1(2,N)=I LINE1(3,N)=KK LINE1(4,N)=AMOD(ATAN2(SINA,COSA)*RTOD+180.0,180.0)+0.5 IF (N.LT.4) GO TO 1480 WRITE (6,1470) ((LINE1(L,N),L=1,4),N=1,4) 1470 FORMAT(4(I5,2H -,I3,2H -,I3,I4)) N=0 1480 CONTINUE 1490 CONTINUE 1500 CONTINUE IF (N.NE.0) WRITE (6,1470) ((LINE1(L,J),L=1,4),J=1,N) N = -1 NATM1=NAT-1 DO 1800 I=1,NATM1 DO 1780 J=I,NAT DO 1740 K=1,NSYM IF (I.EQ.J.AND.K.EQ.1) GO TO 1740 IF (JSYMM(I,J,K,IB,XS,X1).NE.0) GO TO 1740 IBJ=100*IB(1)+10*IB(2)+IB(3) IF (IBJ.EQ.555.AND.K.EQ.1) GO TO 1740 DIST=QUAD4(X1,X1,T) IF (DIST.GT.DMUT) GO TO 1740 IF (DIST.LT.0.2.AND.I.EQ.J) ICON(I)=10000 ISIM=MOD(K,NEQV) IF (ISIM.EQ.0) ISIM=NEQV IP=(K-1)/NEQV ILAT=MOD(IP,MLAT)+1 IF (IP.GE.MLAT) ISIM=-ISIM N=N+1 IF (N.EQ.0) WRITE (6,1550) 1550 FORMAT(//11X,'DISTANCES BETWEEN ATOMS IN DIFFERENT ASYMMETRIC ', 1 'UNITS'//2(4X,34HFROM TO SYMM X Y Z DIST)) IF (N.EQ.0) N = 1 LINE1(N,1)=I LINE1(N,2)=J LINE1(N,3)=ISIM ENIL1(N,1)=FLOAT(IB(1))+TL(1,ILAT)-5.0 ENIL1(N,2)=FLOAT(IB(2))+TL(2,ILAT)-5.0 ENIL1(N,3)=FLOAT(IB(3))+TL(3,ILAT)-5.0 ENIL1(N,4)=SQRT(DIST) IF (N.LT.2) GO TO 1740 WRITE (6,1710) ((LINE1(N,L),L=1,3),(ENIL1(N,L),L=1,4),N=1,2) 1710 FORMAT(2(I8,I4,1H(,I3,3F5.2,1H),F6.2)) N=0 1740 CONTINUE 1780 CONTINUE 1800 CONTINUE IF (N.GT.0) WRITE (6,1710) ((LINE1(J,L),L=1,3), 1 (ENIL1(J,L),L=1,4),J=1,N) DO 1850 I=1,NAT IF (ICON(I).GT.999) WRITE (6,1840) I 1840 FORMAT(/5H PEAK,I4,28H LIES ON A SYMMETRY ELEMENT/) 1850 CONTINUE IF (NN.LE.0) GO TO 1900 IF (NN.GT.1) CALL ISORT(ISYM,NN) ISYM(NN+1)=0 JJ=0 K=0 DO 1890 I=1,NN II=ISYM(I)/250000 IF (II.NE.JJ) WRITE (6,1860) II 1860 FORMAT(/9H CLUSTER,I3,' JOINS TO ITSELF THROUGH THE PEAK ', 1 'PAIR(S)') JJ=II K=K+2 LW(K-1)=MOD(ISYM(I),250000)/500 LW(K)=MOD(ISYM(I),500) IF (K.LT.12.AND.II.EQ.ISYM(I+1)/250000) GO TO 1890 WRITE (6,1870) (LW(J),J=1,K) 1870 FORMAT(/1X,6X,6(I7,1H,,I3)/) K=0 1890 CONTINUE 1900 RETURN END C ------------------------------------------------------------------ C RETRIEVE CENTRING TRANSLATIONS SUBROUTINE CENTRE4(J,L) COMMON /CENT/ TL(3,4),TS(72),FS(216),MLAT,NEQV DIMENSION TST(21) DATA TST/0.,0.,0., 0.,0.5,0.5, 0.5,0.,0.5, 0.5,0.5,0., 0.5,0.5,0.5 1 , 0.333333,0.666667,0.666667, 0.666667,0.333333,0.333333/ MLAT=J M=3*L-2 TL(1,J)=TST(M) TL(2,J)=TST(M+1) TL(3,J)=TST(M+2) RETURN END C ------------------------------------------------------------------ C COMPUTE EIGENVECTORS AND EIGENVALUES OF REAL SYMMETRIC MATRIX SUBROUTINE EIGEN(B,V,IND) DIMENSION B(3,3),V(3,3),IND(3) DO 1020 I=1,3 DO 1000 J=1,3 V(I,J)=0.0 1000 CONTINUE V(I,I)=1.0 1020 CONTINUE 1040 KNT=0 IND1=1 IND3=1 DO 1500 I=1,2 IP1=I+1 DO 1460 J=IP1,3 IF (ABS(B(I,J)) .LT. 0.000001 * B(IND1,IND1)) KNT = KNT + 1 BIJ=B(I,I)-B(J,J) IF (ABS(B(I,J)).LT.ABS(BIJ)) GO TO 1100 T=SIGN(1.0,B(I,J)*BIJ) GO TO 1180 1100 T=B(I,J)/BIJ 1180 G=T/(2.0+2.0*T*T) SN=2.0*G/(1.0+G*G) CS=1.0-G*SN DO 1200 K=1,3 BIK=B(I,K) B(I,K)=CS*B(I,K)+SN*B(J,K) B(J,K)=CS*B(J,K)-SN*BIK 1200 CONTINUE DO 1220 K=1,3 BKI=B(K,I) B(K,I)=CS*B(K,I)+SN*B(K,J) B(K,J)=CS*B(K,J)-SN*BKI VKI=V(K,I) V(K,I)=CS*V(K,I)+SN*V(K,J) V(K,J)=CS*V(K,J)-SN*VKI 1220 CONTINUE 1460 CONTINUE IF (B(IP1,IP1).GT.B(IND1,IND1))IND1=IP1 IF (B(IND3,IND3).GT.B(IP1,IP1))IND3=IP1 1500 CONTINUE IF (KNT.LT.3) GO TO 1040 IND(1)=IND1 IND(2)=1 IND(3)=IND3 IF (IND1.EQ.IND(2).OR.IND3.EQ.IND(2))IND(2)=2 IF (IND1.EQ.IND(2).OR.IND3.EQ.IND(2))IND(2)=3 C CHECK FOR RIGHT-HANDED SET OF VECTORS DET = V(1,1)*(V(2,2)*V(3,3)-V(2,3)*V(3,2))+V(1,2)*(V(2,3)*V(3,1) 1 -V(2,1)*V(3,3))+V(1,3)*(V(2,1)*V(3,2)-V(2,2)*V(3,1)) IF (DET .GT. 0.0) RETURN DO 1520 I=1,3 V(I,3) = -V(I,3) 1520 CONTINUE RETURN END C ------------------------------------------------------------------ C SORT PEAKS IN ORDER OF PEAK HEIGHT OR IN ORDER OF PLOTTING SUBROUTINE SORT4(X,KUSER1,NAT,N) DIMENSION X(4,KUSER1),T(4) INT=2 1000 INT=INT+INT IF (INT.LT.NAT) GO TO 1000 INT=MIN0(NAT,(3*INT)/4-1) 1020 INT=INT/2 IFIN=NAT-INT DO 1200 II=1,IFIN I=II J=I+INT IF (X(N,I).GE.X(N,J)) GO TO 1200 DO 1060 K=1,4 T(K)=X(K,J) 1060 CONTINUE 1080 DO 1100 K=1,4 X(K,J)=X(K,I) 1100 CONTINUE J=I I=I-INT IF (I)1140,1140,1120 1120 IF (X(N,I).LT.T(N)) GO TO 1080 1140 DO 1160 K=1,4 X(K,J)=T(K) 1160 CONTINUE 1200 CONTINUE IF (INT.NE.1) GO TO 1020 RETURN END C ------------------------------------------------------------------ C GENERAL INTEGER SORT ROUTINE SUBROUTINE ISORT(N,M) DIMENSION N(M) INT=2 1000 INT=INT+INT IF (INT.LT.M) GO TO 1000 INT=MIN0(M,(3*INT)/4-1) 1020 INT=INT/2 IFIN=M-INT DO 1200 II=1,IFIN I=II J=I+INT IF (N(I).LE.N(J)) GO TO 1200 IT=N(J) 1080 N(J)=N(I) J=I I=I-INT IF (I.GT.0.AND.N(I).GT.IT) GO TO 1080 N(J)=IT 1200 CONTINUE IF (INT.NE.1) GO TO 1020 RETURN END C ------------------------------------------------------------------ C ELIMINATE THE IITH PEAK AND UPDATE THE BONDING ARRAY SUBROUTINE ELIM(II,NNN,JCN,JBND,ICN,KUSER1) DIMENSION JCN(KUSER1), ICN(KUSER1), JBND(2000) JCN(II)=0 NNN=0 KS=ICN(II)+1 KL=ICN(II+1) IF (KS.GT.KL) RETURN DO 20 I=KS,KL J=JBND(I)/8192 JCN(J)=JCN(J)-1 JBND(I)=0 KB=ICN(J)+1 KE=ICN(J+1) IF (KB.GT.KE) GO TO 20 DO 10 K=KB,KE L=JBND(K)/8192 IF (L.EQ.II) JBND(K)=0 10 CONTINUE 20 CONTINUE RETURN END C ------------------------------------------------------------------ C FUNCTION USED IN THE CALCULATION OF DISTANCES AND ANGLES FUNCTION QUAD4(X1,X2,T) DIMENSION X1(3),X2(3),T(3,3) QUAD4=0.0 DO 1000 I=1,3 QUAD4 = QUAD4+X2(I)*(T(I,1)*X1(1)+T(I,2)*X1(2)+T(I,3)*X1(3)) 1000 CONTINUE RETURN END C ------------------------------------------------------------------ C PERFORM THE KTH SYMMETRY OPERATION ON THE JTH PEAK C AND MOVE IT AS CLOSE AS POSSIBLE TO PEAK I BY LATTICE TRANSLATIONS FUNCTION JSYMM(I,J,K,IB,XS,X1) COMMON /ATOMS/ X(4,400) COMMON /MISC/ ITLE(80),CELL(6),T(3,3),DXMAX(3),MCON,IWT,FOM CHARACTER ITLE DIMENSION IB(3),XS(3),X1(3) JSYMM = 0 CALL OPER4(K,XS,X(1,J),X(2,J),X(3,J)) DO 1080 L=1,3 IB(L)=5 1060 X1(L)=X(L,I)-XS(L) IF (ABS(X1(L)).LE.0.5) GO TO 1070 XS(L)=XS(L)+SIGN(1.0,X1(L)) IB(L)=IB(L)+ISIGN(1,IFIX(2.0*X1(L))) GO TO 1060 1070 IF (ABS(X1(L)) .GT. DXMAX(L)) GO TO 1100 1080 CONTINUE RETURN 1100 JSYMM = 1 RETURN END C ------------------------------------------------------------------ C APPLY J'TH SYMMETRY ELEMENT TO X,Y,Z & PUT RESULT IN XN SUBROUTINE OPER4(J,XN,X,Y,Z) DIMENSION XN(3) COMMON /CENT/ TL(12),TS(72),FS(216),MLAT,NEQV ISYM=MOD(J,NEQV) IF (ISYM.EQ.0) ISYM=NEQV IP=(J-1)/NEQV ILAT=3*MOD(IP,MLAT) JT=3*(ISYM-1) JJ=9*ISYM-8 DO 20 L=1,3 IND1=JT+L IND2=ILAT+L XN(L)=X*FS(JJ)+Y*FS(JJ+1)+Z*FS(JJ+2) IF (IP.GE.MLAT) XN(L)=-XN(L) XN(L)=XN(L)+TS(IND1)+TL(IND2) JJ=JJ+3 20 CONTINUE RETURN END C ------------------------------------------------------------------ C POINT BY POINT FRAGMENT COMPARISON SUBROUTINE TELL(N,NR,M,MR,MERIT,KOMP,INA,INP,LLW) DIMENSION JNP(400),JNA(400),LMP(400),LMA(400) DIMENSION INA(6,400),INP(6,400),LLW(400) COMMON ISYM(100),INBOND(1000),IFRAG(400),ICON(400), 1 IBOND(2000),JFRAG(400),JCON(400),JBOND(2000),IUSE(400), 2 IONA(6,400),IONP(6,400),MO(400),MU(400),NO(400),NU(400), 3 KEYST(400),LW(400),LR(400),LX(400),JK(400),IK(400),KEY(400), 4 IPL(400),KAN(400),CON(400),LL(400),IA(6,400),LS(400),DUM(14400) COMMON/CONST/ DTOR, ANGMIN, ANGMAX, DMIN, 1 DMAX,DMUT,DM,DFRG,NSYM,NUMSET,NATM,NAT,METAL ICOUNT=0 NAX=MAX0(N,M) DO 20 I=1,NAX KEY(I)=0 IPL(I)=0 MO(I)=0 20 CONTINUE KY=MAX0(NR,6) LY=MAX0(MR,6) L=1 LMP(1)=0 LMA(1)=0 DO 50 I=1,NAX LMP(I+1)=LMP(I) LMA(I+1)=LMA(I) DO 40 J=1,6 IF (INA(J,I).GT.I.OR.INA(J,I).EQ.0) GO TO 30 K=LMA(I+1)+1 JNA(K)=INA(J,I) LMA(I+1)=K 30 IF (INP(J,I).EQ.0) GO TO 40 K=LMP(I+1)+1 JNP(K)=INP(J,I) LMP(I+1)=K 40 CONTINUE 50 CONTINUE NF=0 LR(M+1)=0 DO 90 I=1,M MM=M+1-I LR(MM)=LR(MM+1)+LLW(MM) 90 CONTINUE 100 IK(L)=LMA(L) IF (L.LE.M) GO TO 200 150 L=L-1 IF (L.EQ.0) GO TO 500 IF (KEY(L).EQ.0) GO TO 150 KX=KEY(L) NF=NF-LLW(L) IPL(KX)=0 IF (MERIT.GT.LR(1)) GO TO 150 200 IF (NF.NE.0) GO TO 230 K=KEY(L)+1 IF (K.LE.N) GO TO 350 220 KEY(L)=0 L=L+1 IF (NF+LR(L).GE.MERIT) GO TO 100 GO TO 150 230 IF (IK(L).NE.LMA(L).AND.JK(L).NE.KAN(L)) GO TO 260 240 IK(L)=IK(L)+1 IF (IK(L).GT.LMA(L+1)) GO TO 220 K=IK(L) K=JNA(K) IF (KEY(K).EQ.0) GO TO 240 K=KEY(K) JK(L)=LMP(K) KAN(L)=LMP(K+1) 260 JK(L)=JK(L)+1 K=JK(L) K=JNP(K) IF (IPL(K).NE.0) GO TO 230 LP=LMP(K+1) LA=LMA(L+1) IF (L.GT.LY) GO TO 290 LJ=LMA(L) 270 LJ=LJ+1 IF (LJ.GT.LA) GO TO 290 J=JNA(LJ) IF (KEY(J).EQ.0) GO TO 270 LB=LMP(K)+1 280 IF (LB.GT.LP) GO TO 230 IF (JNP(LB).EQ.KEY(J)) GO TO 270 LB=LB+1 GO TO 280 290 IF (K.GT.KY) GO TO 350 LJ=LMP(K) 300 LJ=LJ+1 IF (LJ.GT.LP) GO TO 350 J=JNP(LJ) IF (IPL(J).EQ.0) GO TO 300 LB=LMA(L)+1 310 IF (LB.GT.LA) GO TO 230 IF (JNA(LB).EQ.IPL(J)) GO TO 300 LB=LB+1 GO TO 310 350 KEY(L)=K IPL(K)=L NF=NF+LLW(L) ICOUNT=ICOUNT+1 IF (NF.LT.MERIT) GO TO 400 MERIT=NF+1 DO 380 I=1,NAX IF (KOMP.EQ.1) MO(I)=KEY(I) IF (KOMP.EQ.2) MO(I)=IPL(I) 380 CONTINUE 400 L=L+1 IF (ICOUNT.LT.100000) GO TO 100 WRITE (6,450) 450 FORMAT(/1X,30X,'WARNING - FRAGMENT COMPARISON TOO COMPLICATED ', 1 'FOR PROGRAM') 500 RETURN END C ------------------------------------------------------------------ C CANONICAL DESCRIPTION & SORT FOR FRAGMENT COMPARISON SUBROUTINE CANON(M,MR) COMMON ISYM(100),INBOND(1000),IFRAG(400),ICON(400), 1 IBOND(2000),JFRAG(400),JCON(400),JBOND(2000),IUSE(400), 2 IONA(6,400),IONP(6,400),MO(400),MU(400),NO(400),NU(400), 3 KEYST(400),LW(400),LR(400),LX(400),JK(400),IK(400),KEY(400), 4 IPL(400),CAN(400),CON(400),LL(400),IA(6,400),LS(400),DUM(14400) DO 20 I=1,M CON(I)=1.0 CAN(I)=0.0 LL(I)=0 NU(I)=0 DO 10 J=1,6 IF (IONP(J,I).GT.0) LL(I)=LL(I)+1 10 CONTINUE 20 CONTINUE AM=0.0 DO 110 I=1,M DO 80 J=1,M DO 70 K=1,6 L=IONP(K,J) IF (L.GT.0) CAN(J)=CAN(J)+CON(L) 70 CONTINUE 80 CONTINUE DO 90 J=1,M CON(J)=CAN(J) CAN(J)=0.0 IF (I.EQ.M) AM=AMAX1(AM,CON(J)) 90 CONTINUE 110 CONTINUE DO 130 I=1,M A=CON(I)/AM A=10000.0*A*A LX(I)=A+20000.5 IF (LX(I).EQ.20000) LX(I)=20001 130 CONTINUE DO 255 IEN=1,10 DO 250 I=1,M IF (LL(I).NE.1) GO TO 250 DO 240 K=1,M IF (LL(K).LE.1) GO TO 240 DO 230 J=1,6 IF (IONP(J,K).EQ.I) LL(K)=LL(K)-1 230 CONTINUE 240 CONTINUE LL(I)=0 LX(I)=LX(I)-20000 250 CONTINUE 255 CONTINUE DO 300 I=1,M LM=0 DO 280 J=1,M IF (LX(J).LE.LM) GO TO 280 IF (I.EQ.1) GO TO 270 DO 260 K=1,6 L=IONP(K,J) IF (L.EQ.0) GO TO 280 IF (NU(L).NE.0) GO TO 270 260 CONTINUE GO TO 280 270 LM=LX(J) IX=J 280 CONTINUE NU(IX)=I DO 290 J=1,6 IA(J,I)=IONP(J,IX) 290 CONTINUE LS(I)=LX(IX) LX(IX)=0 300 CONTINUE MR=0 DO 350 I=1,M LX(I)=LS(I) IF (LL(I).GT.1) MR=MR+1 DO 330 J=1,6 IONP(J,I)=0 IF (IA(J,I).EQ.0) GO TO 330 MIN=1000 DO 320 K=1,6 IF (IA(K,I).LE.0) GO TO 320 IX=IA(K,I) IF (MIN.LT.NU(IX)) GO TO 320 MIN=NU(IX) KM=K 320 CONTINUE IONP(J,I)=MIN IA(KM,I)=-1 330 CONTINUE 350 CONTINUE RETURN END