PROGRAM PHASEX ********************************** U625002 PHASEX FORTRAN N = PHASEX.FOR ***** PHASEX ****** Last update: 11 Nov. 1999 ***** ****** Source: Dirdif / CS 1988 *PHASEX LOG of recent modifications C 25 sep DDOKA : KEPROX returns! 11 Nov: STOP 99 C 24 Sep Because of Linux: LINK, UNPACK replaced by XXLINK & XUNPAK C 7 Apr 99: Corr in COMFOM: if no Quartets: clear quartet FOMS COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 PARAMETER (ISIZ = 59876) INTEGER *2 ITAB(ISIZ) CALL KEPROG ('PHASEX') WRITE (LIS2, FMT = '('' Last PHASEX update: 11 Nov. 1999'')') WRITE (LIS1, FMT='('' The program PHASEX performs the'', * '' DIRDIF phase expansion and refinement''/ * '' procedure by application of direct metods to difference'', * '' structure factors'')') CALL DIFTIN IPSQ = 0 CALL DDOP IF (IDC .GT. 0) CALL DACOP IF (IDC .GT. 1) CALL DAMAIN IF (IDC .EQ. 1) CALL DCMAIN IF (IDC .GT. 0) CALL DACEND CALL DDTAN CALL KEPROX WRITE (LIS2, FMT='(/'' Test: DDOKA exit MAIN SUBPROGRAM ''/)') STOP 99 END SUBROUTINE DIFTIN COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH, SWIPRI, EXPAND EQUIVALENCE (SWIPRI, SWITCH(10)), (EXPAND, SWITCH(23)) COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 EQUIVALENCE (IDDL, IFILE( 1)), (ICRYS, IFILE( 3)) EQUIVALENCE (ICON, IFILE( 4)), (LIS1, IFILE( 7)) EQUIVALENCE (LIS2, IFILE( 8)), (IE100, IFILE(10)) EQUIVALENCE (IBINDU, IFILE(14)) EQUIVALENCE (NBINDU, KEYS (14)) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 PARAMETER (ISIZ = 59876) INTEGER *2 ITAB(ISIZ) EQUIVALENCE (MAXHKL(1),MAXH), (MAXHKL(2),MAXK), (MAXHKL(3),MAXL) PARAMETER (MAXBUF = 198) DIMENSION BUFDUA(MAXBUF) DIMENSION FITDUA(7) EQUIVALENCE (FITDUA(1), HCODE), (FITDUA(2), E1), (FITDUA(3), E2), * (FITDUA(5), P1), (FITDUA(6), P2), (FITDUA(7), W1) DIMENSION KARR(100), MAXHC(3), IHKL(3), HKL(3) PARAMETER (LCMAX = 8) CHARACTER LCONDA(LCMAX) *6 DATA LCONDA / 'PHASEX', 'NCEST', 'ACCEPT', 'LOCCEN', 'STLMAX', * 'MAXHKL', 'DIRP1', 'PRINT' / DATA K, IBIG, NN / 0, 0, 0/ EMIN = 0.9 STLMAX = 1.0 MAXREF = 2047 CALL KERNZI (0, MAXHKL, 3) CALL KERNZA (0., TO, 3) CALL KERNZA (0., ESTART, 5) CALL KERNZA (0., E2AG, 7) CALL KERNZA (0., E2CG, 7) DO 190 I=1,ISIZ 190 ITAB(I) = 0 WRITE (LIS2, 200) ISIZ 200 FORMAT (/' Available storage: ', I6) NC = 0 E2AGE = 0.0 E2CGE = 0.0 NR = 0 IDC = 0 QEET = 0.8 MAXT = 60 CALL KERNZI (0, MAXHKL, 3) CALL KERNZI (0, MAXHC, 3) CALL RDCRYS (ICRYS) KEYS(19) = ICENT 210 CALL RDCOND (ICON, LCONDA, LCMAX, KEND) GOTO (210, 211, 212, 213, 214, 215, 216, 217) KEND IF (KEND .EQ. 0) GOTO 260 CALL KERROR ('Error reading CONDA file', 0, 'DIFTIN') 211 IF (NFNUM .NE. 6) CALL KERNER (211, 'DIFTIN') NC = IFIX(FNUM(1)) IF (NC .GT. 5) NC = 5 CALL KERNAB (FNUM(2), ESTART, 5) GOTO 210 212 IF (NFNUM .NE. 2) CALL KERNER (212, 'DIFTIN') QEET = FNUM(1) IF (QEET .LT. 0.5) QEET = 0.5 MAXT = IFIX(FNUM(2)) IF (MAXT .LT. 10) MAXT = 60 GOTO 210 213 IF (NFNUM .NE. 3) CALL KERNER (213, 'DIFTIN') CALL KERNAB (FNUM, TO, 3) IDC = 1 GOTO 210 214 IF (NFNUM .NE. 1) CALL KERNER (214, 'DIFTIN') STLMAX = FNUM(1) GOTO 210 215 IF (NFNUM .NE. 3) CALL KERNER (215, 'DIFTIN') CALL KERF2I (FNUM, MAXHC, 3) GOTO 210 216 EXPAND = .TRUE. GOTO 210 217 SWIPRI = .TRUE. GOTO 210 260 CALL FILINQ (IE100, 'E100', 'FORMATTED', 'INPUT', KINQ) IF (KINQ .NE. 0) CALL KERROR ('No E100 file found', 0, 'DIFTIN') CALL KERINA (IE100, LIT, 1, LEND) IF (LIT(1).NE.'E100' .OR. LIT(2).NE.CCODE) CALL KERROR * ('Error reading E100 file', 0, 'DIFTIN') NGN = IFIX(FNUM(1)) NSP = IFIX(FNUM(2)) E2ALE = FNUM(3) E2CLE = FNUM(4) CALL LOGRD (IDDL, 'PHASEX', KLOG) CALL FILCLO (IDDL, 'KEEP') IF (KLOG.LE.0 .OR. LIT(5).NE.'MHKL' .OR. LIT(6).NE.'NREFL1') * CALL KERROR ('Error reading DDLOG file', 0, 'DIFTIN') CALL KERF2I (FNUM(4), MAXHKL, 3) NR = IFIX(FNUM(7)) IF (MAXHKL(1).EQ.0 .AND. MAXHKL(2).EQ.0 .AND. MAXHKL(3).EQ.0) * CALL KERROR ('No MAXHKL given on DDLOG file', 0, 'DIFTIN') IF (NR .EQ. 0) * CALL KERROR ('No NREFL1 given on DDLOG file', 0, 'DIFTIN') IF (NGN.EQ.0 .AND. NSP.EQ.0) * CALL KERROR ('No NGN or NSP given on E100 file', 0, 'DIFTIN') IF (E2ALE.LT.0.01 .AND. E2CLE.LT.0.01) CALL KERROR * ('No E2ACLE or E2CLE given on E100 file', 0, 'DIFTIN') DO 265 I=1,3 265 IF (MAXHC(I) .GT. 0) MAXHKL(I) = MIN0(MAXHKL(I), MAXHC(I)) KORIS = 0 IICENT = ICENT IF (EXPAND) IICENT = 1 IF (IDC .EQ. 0) CALL LOCCEN (IDC, TO) IF (IDC .GT. 0) THEN KORIS = 1 IDC = 1 ENDIF IF (IDC .EQ. 0) GOTO 310 IF (IICENT .EQ. 1) GOTO 280 WRITE (LIS2, 270) 270 FORMAT ('0Input LOCCEN ignored' /) IDC = 0 KORIS = 0 GOTO 310 280 WRITE (LIS1, 285) WRITE (LIS2, 285) 285 FORMAT (/ ' ***** Enantiomorph fixation *****' /) IF (ABS(TO(1)).LT..001 .AND. ABS(TO(2)).LT..001 .AND. * ABS(TO(3)).LT..001) THEN KORIS = 0 GOTO 310 ENDIF WRITE (LIS1, 290) TO WRITE (LIS2, 290) TO 290 FORMAT (' The origin is shifted over a vector (',3(F6.3,','),')') WRITE (LIS2, 300) 300 FORMAT(' All phases printed by PHASEX are in agreement with the', * ' new origin', / ' phases on the final output file are', * ' set back to the original origin') CALL PSEUDO (TO) 310 CALL BINIFF (1, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA) E000R = BUFDUA(5) PSQ = BUFDUA(6) R2X = BUFDUA(7) WRITE (LIS2, FMT='('' Input atoms resulted in R2 ='',F6.3)') R2X IF (PSQ .GT. 0.99) CALL KERROR ('PSQ too big...', 310, 'DIFTIN') IF (NC .GT. 0) GOTO 320 IF (IDC .EQ. 1) NC = 2 NC = 3 IF (NR .LT. 200) NC = 2 320 IDC3 = IDC + 1 IF (ESTART(1) .GT. 0.1) GOTO 340 XX = 1.3 IF (IICENT .EQ. 2) XX = 1.5 DO 330 I=1,NC 330 ESTART(I) = XX - 0.1*(I/2) 340 WRITE (LIS2, 350) EMIN, NC, (ESTART(I), I=1,NC) 350 FORMAT (/ ' Start E1min = ', F4.2, ' Tangent formula:' / * 29X, 'minimum Er for', I2, ' cycles : ', 5F5.2) IF (IDC .NE. 1) GOTO 370 ESTART(1) = ESTART(1) - 0.1 ESTAR1 = ESTART(1) WRITE (LIS2, 360) ESTAR1 360 FORMAT (26X, 'Min E1 for cycle zero (with symbols): ', F4.2) 370 WRITE (LIS2, FMT='('' MAXHKL:'', 3I4)') MAXHKL MCTMAX = 32767 I34 = 1 I35 = 1 MCTLAT = 1 FR = 1. M = 0 MS = 1 CALL KERNAI (MAXHKL, IHKL, 3) 380 GOTO (410, 400, 390), I35 390 IF (MOD(MAXL,3) .GT. 0) MAXL = MAXL + 3 - MOD(MAXL,3) GOTO 410 400 MAXL = MAXL + MOD(MAXL,2) 410 MCK = 2*MAXL/I35 + 1 IF (I34 .EQ. 2) MAXK = MAXK + MOD(MAXK,2) MCH = MCK * (2*MAXK/I34+1) MCT = MCH*MAXH + MCK*MAXK/I34 + MAXL/I35 IF (MCT .LE. MCTMAX) GOTO 470 GOTO (420, 430, 430, 460), MS 420 MS = 2 IF (MCT .LE. 5*MCTMAX/4) GOTO 430 IF (ILATT.EQ.1) GOTO 430 MCTLAT = ILATT IF (ILATT.EQ.6 .AND. MCT.LE.7*MCTMAX/3) MCTLAT = 3 IF (MCTLAT.EQ.6 .OR. MCTLAT.EQ.4) I34 = 2 IF (MCTLAT .NE. 4) I35 = 2 IF (MCTLAT .EQ. 7) I35 = 3 GOTO 380 430 M = 1 FR = FR * ( (FLOAT(MCT)/MCTMAX - 1.)/3. + 1. ) DO 450 N=1,3 450 MAXHKL(N) = IHKL(N)/FR + 1. IF (MS .LT. 4) MS = MS + 1 GOTO 380 460 FR = FR * 1.02 GOTO 430 470 IF (M .GT. 0) WRITE (LIS2, 480) MAXHKL 480 FORMAT ('0Storage too small; new MAXHKL: ', 3I3) WRITE (LIS2, 500) MCH, MCK, I34, I35, MCT 500 FORMAT (' Packed indices are', I14, '*H + ', I4, '*K/', I1, * ' + L/', I1, /, ' Dimension of address table is', I22) I34 = MAXK / I34 I35 = MAXL / I35 KK = 0 ICR = 9 NTAL = ISIZ - ICR MAXRE = (ISIZ-MCT) / 10 IF (MAXRE .GT. MAXREF-5) MAXRE = MAXREF - 5 WRITE (LIS2, 503) MAXRE 503 FORMAT (' Dimension of reflection table is', I19) EMINO = EMIN EMAX = EMIN + 0.9 CALL VALDIS (-1, EMIN, EMAX, KARR, 100, NREFDI) MMS = 1 NCOUNT = 500 NBINDU = 0 510 CALL BINIFF (0, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA) IF (KENDUA .LT. 0) GOTO 580 NBINDU = NBINDU + 1 CALL HKLC1U (HCODE, HKL) CALL HKLSTL (HKL, STL, STL2) IT = 1 IF (.NOT. EXPAND) IT = IPHFIX (HKL) ITP = IT - 1 EEX = E2EXP (ITP, E1, E2) CALL KERF2I (HKL, IHKL, 3) IF (MAXH.LT.IABS(IHKL(1)) .OR. MAXK.LT.IABS(IHKL(2)) .OR. * MAXL.LT.IABS(IHKL(3)) .OR. E1.LT.EMIN .OR. * STL.GT.STLMAX) GOTO 570 ITAB(NCOUNT+1) = IHKL(1) ITAB(NCOUNT+2) = IHKL(2) ITAB(NCOUNT+3) = IHKL(3) ITAB(NCOUNT+4) = NINT (100.*E1) ITAB(NCOUNT+5) = NINT (100.*E2) IF (ABS(P1-P2) .LT. 5.) ITAB(NCOUNT+5) = -ITAB(NCOUNT+5) IF (KORIS .EQ. 1) CALL ORSHIF (HKL, TO, P1, P2, 0., KORIS) ITAB(NCOUNT+6) = NINT (P1) IF (ITAB(NCOUNT+6) .GE. 360) ITAB(NCOUNT+6) = ITAB(NCOUNT+6) - 360 ITAB(NCOUNT+7) = NINT (1000.*W1) ITAB(NCOUNT+8) = IT ITAB(NCOUNT+9) = NINT (100.*EEX) CALL VALDIS (0, E1, 0., KARR, 100, NREFDI) NCOUNT = NCOUNT + ICR IF (NCOUNT .LT. NTAL-ICR) GOTO 510 CALL VALDIS (MAXRE, EMIN, 0., KARR, 100, NREFDI) WRITE (LIS2, 520) EMIN 520 FORMAT (' Too many refl.; new E1min =', F5.2) IF (EMIN .GT. EMAX) THEN WRITE (LIS1, 522) EMAX-1., EMAX-0.99, EMAX-0.98, EMAX-0.97, * (KARR(I), I= 1,100) WRITE (LIS2, 522) EMAX-1., EMAX-0.99, EMAX-0.98, EMAX-0.97, * (KARR(I), I= 1,100) 522 FORMAT (' Expected scaling error: distribution of E1 values:'/ * 3X, 4F5.2, ' ....'/ (5X, 12I5) ) EMIN = EMAX WRITE (LIS2, 524) EMIN 524 FORMAT (' Reset: ........ new E1min =', F5.2) IF (EMIN .GT. EMINO + 1.0) THEN CHOUT= ' Too many tryals: scaling error!: see what happens.' CALL SHOUT2 ENDIF ENDIF EMAX = EMIN + 0.9 CALL VALDIS (-1, EMIN, EMAX, KARR, 100, NREFDI) KK = NCOUNT NCOUNT = 500 K = 500 MMS = 2 530 E1 = ITAB(K+4) / 100. IF (E1 .GE. EMIN) GOTO 540 EEX = ITAB(K+9) / 100. IT = ITAB(K+8) K = K + ICR GOTO 570 540 DO 550 I=1,9 K = K + 1 NCOUNT = NCOUNT + 1 550 ITAB(NCOUNT) = ITAB(K) CALL VALDIS (0, E1, 0., KARR, 100, NREFDI) 560 IF (K .LT. KK) GOTO 530 MMS = 1 GOTO 510 570 IF (IT .EQ. 1) E2ALE = E2ALE + EEX IF (IT .GT. 1) E2CLE = E2CLE + EEX GOTO (510, 560, 660), MMS 580 CONTINUE WRITE (LIS2, 581) NBINDU 581 FORMAT (' Number of reflections input from file BINDUA:', I6) IF (NREFDI .LT. MAXRE+5) GOTO 600 CALL VALDIS (MAXRE, EMIN, 0., KARR, 100, NREFDI) WRITE (LIS2, 520) EMIN MAXRE = (ISIZ - NCOUNT) / 8 - 5 MAXRE = MIN0 (MAXRE, MAXREF) 600 KK = NCOUNT IF (MCT .GT. NCOUNT) NCOUNT = MCT IBIG = NCOUNT NN = NCOUNT + 8*(MAXRE+5) K = 500 MMS = 3 610 E1 = ITAB(K+4) / 100. EEX = ITAB(K+9) / 100. IT = ITAB(K+8) IF (E1 .GE. EMIN) GOTO 620 K = K + ICR GOTO 570 620 IF (IT.GT.1) GOTO 630 E2AGE = E2AGE + EEX E2AG(1) = E2AG(1) + E1*E1 GOTO 640 630 E2CGE = E2CGE + EEX E2CG(1) = E2CG(1) + E1*E1 640 DO 650 I=1,8 K = K + 1 NCOUNT = NCOUNT + 1 650 ITAB(NCOUNT) = ITAB(K) K = K + 1 660 IF (K.LT.KK .AND. NCOUNT.LT.NN) GOTO 610 IF (IBIG .EQ. MCT) GOTO 680 KK = NCOUNT NCOUNT = MCT K = IBIG + 1 DO 670 I=K,KK NCOUNT = NCOUNT + 1 670 ITAB(NCOUNT) = ITAB(I) 680 NCT = NCOUNT - 8 ICR = 8 RETURN END SUBROUTINE DDOP COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH, SWIPRI, EXPAND EQUIVALENCE (SWIPRI, SWITCH(10)), (EXPAND, SWITCH(23)) COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IBINDO, IFILE(13)) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 PARAMETER (ISIZ = 59876) INTEGER *2 ITAB(ISIZ) COMMON / SINCOS / IDEG(8), ISCT INTEGER*2 ISCT(450) COMMON / KLAD / ICODE(4,48), ISHIFT(48) DIMENSION IPG1(8), KARR(100), IHKL(3) PARAMETER (MAXBUF = 198) DIMENSION FITDOP(9), BUFDOP(MAXBUF) CHARACTER LITOUT *25 CHARACTER LETT(5) *2 DATA LETT / '. ', 'S ', 'R ', 'SR', 'C ' / NITDOP = 9 CALL BINOFF (4, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP) EWMIN = ESTART(1) * 0.16 - 0.01 CALL VALDIS (-1, 0.03, 2. , KARR, 80, MST) MR = (NCT-MCT)/ICR + 1 MSMAX = MIN0 (400, (ISIZ - NCT + MR) / 12) WRITE (LIS2, 200) MR 200 FORMAT (' Number of reflections to be refined: ', I6) NR = MR NLINPR = 0 IF (.NOT. SWIPRI) GOTO 240 WRITE (LIS2, 210) 210 FORMAT ('0Reflection table (max. 300 refl. printed)', /, * ' R = restricted phase (Fp .gt. Fobs)') IF (IICENT .EQ. 1) WRITE (LIS2, 220) 220 FORMAT (' S = special reflection (two possible phase values)') WRITE (LIS2, 230) 230 FORMAT ( '0', 5(' H K L E1 P1 W1 ') /) CHOUT = '(5A25)' CALL LINPRX (LIS2, LITOUT, 25, 5) 240 MS = 0 NWZ = 0 DO 260 K=MCT,NCT,ICR IHKL(1) = ITAB(K+1) IHKL(2) = ITAB(K+2) IHKL(3) = ITAB(K+3) E1 = ITAB(K+4)/100. E2 = ABS(ITAB(K+5)/100.) P1 = ITAB(K+6) W1 = ITAB(K+7)/1000. IF (W1 .LT. 0.01) NWZ = NWZ + 1 IT = ITAB(K+8) PHREST = 180. IF (ITAB(K+5) .LT. 0) PHREST = 57.296 * * ASIN ((E2-E1) / (E2+E1)) EW = E1 * W1 IF (EW .GE. 0.03) CALL VALDIS (0, EW, 0., KARR, 80, MST) IF (E1.LT.ESTART(1) .OR. W1.LT.0.16) GOTO 250 EW = EW + 10. MS = MS + 1 250 LET = 0 IF (IICENT .NE. 1) LET = -1 IF (IT .NE. 1) LET = LET + 2 IF (ITAB(K+5) .LT. 0) LET = LET + 2 CALL KERI2F (IHKL, FITDOP(1), 3) FITDOP(4) = E1 FITDOP(5) = E2 FITDOP(6) = P1 FITDOP(7) = W1 FITDOP(8) = FLOAT(IT) FITDOP(9) = PHREST CALL BINOFF (0, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP) IF (SWIPRI .AND. NLINPR.LT.300) THEN NLINPR = NLINPR + 1 IP1 = NINT(P1) LET = MAX0 (1, LET) WRITE (LITOUT, FMT='(1X, 3I3, F5.2, I4, A2, F4.2)') * IHKL, E1, IP1, LETT(LET), W1 CALL LINPRX (0, LITOUT, 25, 5) ENDIF ITAB(K+5) = EW*1000. + .5 260 CONTINUE IF (SWIPRI) CALL LINPRX (-1, LITOUT, 25, 5) CALL BINOFF (-1,IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP) IF (MS.LE.MSMAX .AND. MS.GE.MSMAX/4) GOTO 280 MSMAXT = MSMAX IF (MS .LE. MSMAX) MSMAXT = MSMAX / 4 CALL VALDIS (MSMAXT, EW, 0., KARR, 80, MST) WRITE (LIS2, 270) EW 270 FORMAT (/' New starting set limitations;' / * ' minimum E1 * W1 is: ', F6.3) EWMIN = EW - 0.001 MST = 0 280 CONTINUE NCOUNT = MCT MS = 0 DO 290 K=MCT,NCT,ICR ITAB(NCOUNT+1) = ITAB(K+1) ITAB(NCOUNT+2) = ITAB(K+2) ITAB(NCOUNT+3) = ITAB(K+3) ITAB(NCOUNT+4) = ITAB(K+4) EW = ITAB(K+5) / 1000. ITAB(NCOUNT+5) = ITAB(K+8) ITAB(NCOUNT+6) = ITAB(K+6) ITAB(NCOUNT+7) = ITAB(K+7) IF (MST.GT.0 .AND. EW.LT.10.) GOTO 290 IF (MST.EQ.0 .AND. EW.GT.10.) EW = EW - 10. IF (EW .LT. EWMIN) GOTO 290 ITAB(NCOUNT+5) = -ITAB(NCOUNT+5) MS = MS + 1 290 NCOUNT = NCOUNT + 7 ICR = 7 NCT = NCOUNT - ICR INCA4 = 4 MARKA4 = NCOUNT - INCA4 MAXA4 = ISIZ - INCA4 ISTO4 = MARKA4 MSMAX = MIN0 (MS, MSMAX+10) WRITE (LIS2, 300) MSMAX 300 FORMAT (' Number of reflections in starting set: ', I4) IF (.NOT. SWIPRI) GOTO 320 WRITE (LIS2, FMT='(''0Starting set (max. 200 refl. printed)'')') NLINPR = 0 WRITE (LIS2, 230) 320 DO 330 I=1,MCT 330 ITAB(I) = 0 CALL KERNZI (0, IPG1, 8) CALL KERNZI (0, IPG2, 8) IILAUE = ILAUE IF (EXPAND) ILAUE = 1 LET = 1 MS = 0 MR = 0 MITAB = 0 E1MIN = 0.9 E1MAX = 3.0 CALL VALDIS (-1, E1MIN, E1MAX, KARR, 100, NRE1) DO 370 NCOUNT=MCT,NCT,ICR MR = MR + 1 IHKL(1) = ITAB(NCOUNT+1) IHKL(2) = ITAB(NCOUNT+2) IHKL(3) = ITAB(NCOUNT+3) W1 = ITAB(NCOUNT+7) / 1000. ITAB(NCOUNT+1) = INPACK(IHKL) ITAB(NCOUNT+2) = W1 * ITAB(NCOUNT+4) +.5 ITAB(NCOUNT+3) = ITAB(NCOUNT+6) ITAB(NCOUNT+7) = ITAB(NCOUNT+4) E1 = ITAB(NCOUNT+4) / 100. CALL VALDIS (0, E1, 0., KARR, 100, NRE1) I = IGROUP (IHKL) IPG2(I) = IPG2(I) + 1 IP1 = ITAB(NCOUNT+6) IF (ITAB(NCOUNT+5) .GT. 0) GOTO 340 IF (MS .GE. MSMAX) GOTO 350 IF (SWIPRI .AND. NLINPR.LT.200) THEN NLINPR = NLINPR + 1 WRITE (LITOUT, FMT='(1X, 3I3, F5.2, I4, A2, F4.2)') * IHKL, E1, IP1, LETT(LET), W1 CALL LINPRX (0, LITOUT, 25, 5) ENDIF CALL IITAB4 (IHKL, NCOUNT) IPG1(I) = IPG1(I) + 1 ITAB(NCOUNT+2) = -ITAB(NCOUNT+2) MS = MS + 1 GOTO 350 340 ITAB(NCOUNT+5) = -ITAB(NCOUNT+5) 350 ITAB(NCOUNT+6) = I NE = 1 CALL SYMEQ (IHKL, NE) ITAB(NCOUNT+4) = NE DO 360 I=1,NE IADR = ICODE(4,I) ISIG = ISIGN(1,IADR) IADR = IABS(IADR) JSI = ISHIFT(I) - 1 ITAB(IADR) = ISIG*(4096*JSI+MR) MITAB = MITAB + 1 360 CONTINUE 370 CONTINUE ILAUE = IILAUE IF (SWIPRI) CALL LINPRX (-1, LITOUT, 25, 5) WRITE (LIS2, 400) IPG1, IPG2 400 FORMAT(/' Distribution of reflections in parity groups or equiva', * 'lent.', /, ' Group 1 is the seminvariant group', / * 16X, ' 1 2 3 4 5 6 7 8', / * 16X, ' ggg ugg gug uug ggu ugu guu uuu', / * ' in starting set ', 8I5, /, ' in entire table ', 8I5) NPG1 = 0 NPG2 = 0 ISIG = 1 IF (MS .LT. 20) ISIG = 0 DO 410 IPG=1,8 IF (IPG2(IPG) .GT. ISIG) NPG2 = NPG2 + 1 IPG2(IPG) = 0 IF (IPG1(IPG).LE.ISIG) GOTO 410 IPG2(IPG) = -1 NPG1 = NPG1 + 1 410 CONTINUE IF (FLOAT(NPG2)/NPG1 .GT. 1.65) IDC = IDC + 2*IICENT NWZ = 100 * NWZ / MR IF (IDC.LE.1 .AND. NWZ.GT.40) IDC = IDC + 2*IICENT PSQMAX = 0.15 IF (IPSQ .LT. 0) PSQMAX = 0.0 IF (IDC.EQ.0 .AND. PSQ.LT.PSQMAX) THEN IDC = IICENT*2 IPSQ = 1 MAXE1 = MIN0 (NRE1, 1000) ENDIF IF (IPSQ .EQ. 0) GOTO 470 MAXE5 = MIN0 (500, NRE1) CALL VALDIS (MAXE5, E500, 0., KARR, 100, NRE1) MAXE1 = MIN0 (1000, NRE1) CALL VALDIS (MAXE1, E1000, 0., KARR, 100, NRE1) WRITE (LIS2, 420) NRE1, MAXE5, E500, MAXE1, E1000, E1MAX 420 FORMAT (' Total number of refl.: ', I5, /, * ' E1min for', I5, ' strongest refl.: ', F5.3, / * ' E1min for', I5, ' strongest refl.: ', F5.3, / * ' E1max: ', F5.3) VINC = (E1MAX - E1MIN) / 98. VSUB = E1MIN - 2.*VINC WRITE (LIS2, FMT='(/'' Distribution of E1:'')') DO 425 I=1,100,25 AS = FLOAT (I) WRITE (LIS2, FMT='('' E1 '', 25F5.2)') (VSUB+VINC*A, A=AS,AS+24.) 425 WRITE (LIS2, FMT='('' NR'', 25I5)') (KARR(J), J=I,I+24) CALL VALDIS (MAXE1, E1MIN, 0., KARR, 100, NRE1) WRITE (LIS2, FMT='('' E1min for FOMs for '', I5, * '' strongest refl.: '', F5.3)') MAXE1, E1MIN I100 = MIN0 (MAXE1, 100) CALL VALDIS (I100, E1100, 0., KARR, 100, NRE1) WRITE (LIS2, FMT='('' E1min for FOMs for '', I5, * '' strongest refl.: '', F5.3)') I100, E1100 470 CONTINUE IF (IDC .GT. 1) GOTO 490 DO 480 NCOUNT=MCT,NCT,ICR ITAB(NCOUNT+4) = 0 ITAB(NCOUNT+5) = 0 ITAB(NCOUNT+6) = 0 480 IF (ITAB(NCOUNT+2).LT.0) ITAB(NCOUNT+2) = -ITAB(NCOUNT+2) 490 E2AGE = (E2AGE + E2ALE)/(MAX0(1,NGN)) E2CGE = (E2CGE + E2CLE)/(MAX0(1,NSP)) E2AG(1) = (E2AG(1) + E2ALE)/(MAX0(1,NGN)) E2CG(1) = (E2CG(1) + E2CLE)/(MAX0(1,NSP)) CALL DD38 IF (IDC.LE.1 .OR. IPSQ.EQ.1) RETURN WRITE (LIS1, 500) WRITE (LIS2, 500) 500 FORMAT (/, ' ***** Origin fixation *****', /) RETURN END SUBROUTINE DDTAN COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH, SWIPRI EQUIVALENCE (SWIPRI, SWITCH(10)) COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IBINDI, IFILE(15)), (IBINDO, IFILE(13)) EQUIVALENCE (NBINDU, KEYS(14)) EQUIVALENCE (ICENT, KEYS(19)) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 PARAMETER (ISIZ = 59876) INTEGER *2 ITAB(ISIZ) PARAMETER (MAXBUF = 198) DIMENSION BUFDIF(MAXBUF), FITDIF(4) EQUIVALENCE (FITDIF(1), HCODE), (FITDIF(2), EL), (FITDIF(3), PL), * (FITDIF(4), WL) DIMENSION IHKL(3), HKL(3), E2TOT(7) CHARACTER LITOUT *25 CHARACTER LETT(5) *2 DATA LETT / '. ', '* ', 'R ', '*R', 'C ' / DATA NLINPR / 0 / WRITE (LIS1, FMT='(/'' Tangent refinement:'')') WRITE (LIS2, FMT='(/'' Tangent refinement:'')') NC = NC + 1 DO 200 ICYC=2,NC CALL GENER CALL STARTS (ICYC) E2AG(ICYC) = (E2AG(ICYC) + E2ALE) / (MAX0(1,NGN)) 200 E2CG(ICYC) = (E2CG(ICYC) + E2CLE) / (MAX0(1,NSP)) CALL FILCLO (IBINDO, 'DELETE') NITDIF = 4 CALL BINOFF (4, IBINDI, 'BINDIF', FITDIF, NITDIF, BUFDIF, KENDIF) NBINDI = 0 IF (KORIS .NE. 1) GOTO 220 DO 210 I=1,3 210 TO(I) = -TO(I) KORIS = 2 CALL PSEUDO (TO) 220 IF (SWIPRI) THEN WRITE (LIS2, 230) 230 FORMAT (/ ' The following table gives the final result of the', * ' program PHASEX.', /, * ' The reflections are marked (max. 300 refl. printed):' / * ' * = refl. with total phase shift of 90 degrees or more', * /' R = refl. with WS.lt.0.9 (unreliable)', /, * ' ', 5(' H K L EL PL WL ') /) NLINPR = 0 CHOUT = '(5A25)' CALL LINPRX (LIS2, LITOUT, 25, 5) ENDIF IPMIN = 0 NPMIN = 0 NCOUNT = MCT - ICR 240 NCOUNT = NCOUNT + ICR IPACK = ITAB(NCOUNT+1) CALL XUNPAK (IPACK, IHKL) CALL KERI2F (IHKL, HKL, 3) LET = 1 IP1 = ITAB(NCOUNT+4) IPS = ITAB(NCOUNT+3) EL = ITAB(NCOUNT+7)/100. WS = ABS (ITAB(NCOUNT+2) * 0.01/EL) IF (WS .GT. 1.0) WS = 1.0 PL = IPS IF (IDC .NE. 1) GOTO 260 PL = PL / 57.29 AEL = EL * COS(PL) BEL = EL * SIN(PL) * 2.00 EL = SQRT(AEL**2 + BEL**2) PL = ATAN2(BEL,AEL) * 57.29 IF (PL .LT. 0.) PL = PL + 360. 260 WL = WS IF (KORIS .EQ. 2) CALL ORSHIF (HKL, TO, 0., 0., PL, KORIS) IF (WS .LT. 0.9) LET = 3 IF (ITAB(NCOUNT+5) .GE. 0) GOTO 270 LET = 5 GOTO 280 270 IDIF = IABS(IPS-IP1) IDIF = MIN0(IDIF, 360-IDIF) IF (IDIF .GT. 89) LET = LET + 1 280 IPS = INT(PL) IPMIN = IPMIN + MIN0(IABS(IPS), IABS(IABS(IPS)-180)) NPMIN = NPMIN + 1 NBINDI = NBINDI + 1 CALL HKLC1 (HKL, HCODE) CALL BINOFF (0, IBINDI, 'BINDIF', FITDIF, NITDIF, BUFDIF, KENDIF) IF (.NOT. SWIPRI) GOTO 290 IF (SWIPRI .AND. NLINPR.LT.300) THEN NLINPR = NLINPR + 1 WRITE (LITOUT, FMT='(1X, 3I3, F5.2, I4, A2, F4.2)') * IHKL, EL, IPS, LETT(LET), WL CALL LINPRX (0, LITOUT, 25, 5) ENDIF 290 IF (NCOUNT .LT. NCT) GOTO 240 CALL BINOFF (-1, IBINDI, 'BINDIF', FITDIF, NITDIF, BUFDIF, KENDIF) IF (SWIPRI) CALL LINPRX (-1, LITOUT, 25, 5) WRITE (LIS2, 291) NBINDI 291 FORMAT (' Number of reflections output to file BINDIF:', I6) IPMIN = IPMIN / NPMIN IF (ICENT .EQ. 1) WRITE(LIS2, FMT = '(/ * '' Average deviation from 0 degrees (or 180 degrees)'' / * '' for phases used in PHASEX '', I3 , '' degrees '')') IPMIN NBINDI = NBINDU - NBINDI IF (NBINDI .NE. 0) WRITE (LIS2, 292) NBINDI 292 FORMAT (' Number of reflections skipped by PHASEX: ', I6) IF (KORIS .EQ. 2) WRITE (LIS1, 310) IF (KORIS .EQ. 2) WRITE (LIS2, 310) 310 FORMAT (' ***** Origin shifted back *****') NTOT = NGN + NSP ANGN = FLOAT (MAX0(1,NGN)) ANSP = FLOAT (MAX0(1,NSP)) ANTOT = FLOAT (NTOT) E2TOTE = (E2AGE*ANGN + E2CGE*ANSP) / ANTOT DO 320 I=1,7 320 E2TOT(I) = (E2AG(I)*ANGN + E2CG(I)*ANSP) / ANTOT IF (IDC .EQ. 0) THEN WRITE (LIS1, 330) E2TOTE, (I, E2TOT(I), I=1,NC-1) 330 FORMAT(' Values for average E**2', / * ' a priori expectation values ', F7.3, /, * (' calculated before cycle', I5, 6X, F13.3)) WRITE (LIS2, 335) NTOT, E2TOTE, (I, E2TOT(I), I=1,NC-1) 335 FORMAT(' Values for average E**2 for all (', I5, ') reflections'/ * ' a priori expectation values ', F7.3, /, * (' calculated before cycle', I5, 6X, F13.3)) IF (IICENT .EQ. 1) * WRITE (LIS2, 340) NGN, NSP, E2AGE, E2CGE, * (I, E2AG(I), E2CG(I), I=1,NC-1) 340 FORMAT(' Values for average E**2 for', I5, ' general refl. and', * I4, ' special refl.:' / * ' a priori expectation values ', F7.3, 19X, F5.3 / * (' calculated before cycle', I5, 6X, F13.3, 12X, F12.3)) ELSE WRITE (LIS1, 350) E2TOTE, E2TOT(1), E2TOT(7), * (I, E2TOT(I), I=2,NC-1) 350 FORMAT(' Values for average E**2' / * ' a priori expectation values ', F7.3 / * ' calculated at start ', 11X, F13.3 / * ' calculated after symbols', 10X, F13.3 / * (' calculated before cycle', I5, 6X, F13.3)) WRITE (LIS2, 355) NTOT, E2TOTE, E2TOT(1), E2TOT(7), * (I, E2TOT(I), I=2,NC-1) 355 FORMAT('0Values for average E**2 for all (', I5, ') reflections'/ * ' a priori expectation values ', F7.3 / * ' calculated at start ', 11X, F13.3 / * ' calculated after symbols', 10X, F13.3 / * (' calculated before cycle', I5, 6X, F13.3)) IF (IICENT .EQ. 1) * WRITE (LIS2, 360) NGN, NSP, E2AGE, E2CGE, E2AG(1), E2CG(1), * E2AG(7), E2CG(7), (I, E2AG(I), E2CG(I), I=2,NC-1) 360 FORMAT(' Values for average E**2 for general refl. (', I5, * ') and special refl. (', I4, ')' / * ' a priori expectation values ', F7.3, 19X, F5.3 / * ' calculated at start ', 11X, F13.3, 12X, F12.3 / * ' calculated after symbols', 10X, F13.3, 12X, F12.3 / * (' calculated before cycle', I5, 6X, F13.3, 12X, F12.3)) ENDIF WRITE (LIS1, 370) NC-1, E2TOT(NC) 370 FORMAT(' calculated after cycle', I5, 6X, F13.3) WRITE (LIS2, 370) NC-1, E2TOT(NC) IF (IICENT .EQ. 1) WRITE (LIS2, 380) NC-1, E2AG(NC), E2CG(NC) 380 FORMAT(' calculated after cycle', I5, 6X, F13.3, 12X, F12.3) RETURN END SUBROUTINE GENER COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 PARAMETER (ISIZ = 59876) INTEGER *2 ITAB(ISIZ) COMMON / KLAD / ICODE(4,48), ISHIFT(48) COMMON / SINCOS / IDEG(8), ISCT INTEGER*2 ISCT(450) DIMENSION IHKL(3), IHKL3(3), LHIT(48) EQUIVALENCE (IHKL3(1), JJH1), (IHKL3(2), JJH2), (IHKL3(3), JJH3), * (MAXHKL(1),MAXH), (MAXHKL(2),MAXK), (MAXHKL(3),MAXL) DATA K,KTEST / 0, 0/ ISTR1 = MARKA4 + INCA4 + INCA4 ISTR2 = MARKA4 + INCA4 DO 280 I41=ISTR1,ISTO4,INCA4 IR1 = ITAB(I41+4) + MCT IEW1 = ITAB(IR1+2) IPH1 = ITAB(IR1+3) DO 200 I=1,3 200 IHKL(I) = ITAB(I41+I) NEQ = 2 CALL SYMEQ (IHKL, NEQ) DO 210 I=1,NEQ IS2 = ISHIFT(I) ISHIFT(I) = IPH1 + IDEG(IS2) 210 ISHIFT(I+NEQ) = -ISHIFT(I) ISTOP = I41 - INCA4 NEQ2 = NEQ * 2 DO 270 I42=ISTR2,ISTOP,INCA4 JH1 = ITAB(I42+1) JH2 = ITAB(I42+2) JH3 = ITAB(I42+3) IR2 = ITAB(I42+4) + MCT IPH2 = ITAB(IR2+3) IWEE = IEW1 * ITAB(IR2+2) J = ITAB(IR2+1) NHIT = 0 DO 260 I11=1,NEQ2 IF (MCTLAT .GT. 1) GOTO 220 I = ICODE (4, I11) KTEST = I + J K = IABS(KTEST) IF (K .EQ. 0) GOTO 260 IF (K .GT. MCT) GOTO 260 IF (ITAB(K) .EQ. 0) GOTO 260 220 JJH1 = ICODE(1,I11) + JH1 IF (IABS(JJH1) .GT. MAXH) GOTO 260 JJH2 = ICODE(2,I11) + JH2 IF (IABS(JJH2) .GT. MAXK) GOTO 260 JJH3 = ICODE(3,I11) + JH3 IF (IABS(JJH3) .GT. MAXL) GOTO 260 IF (MCTLAT .EQ. 1) GOTO 230 KTEST = INPACK(IHKL3) K = IABS(KTEST) IF (K .EQ. 0) GOTO 260 IF (ITAB(K) .EQ. 0) GOTO 260 230 K = ITAB(K) LTEST = IABS(K) L = LTEST / 4096 IR3 = (LTEST-L*4096-1)*ICR + MCT IF (IR3.EQ.IR2 .OR. IR3.EQ.IR1) GOTO 260 IF (NHIT .EQ. 0) GOTO 250 DO 240 IHIT=1,NHIT IF (IR3 .EQ. LHIT(IHIT)) GOTO 260 240 CONTINUE 250 NHIT = NHIT + 1 LHIT(NHIT) = IR3 L = L + 1 IPH3 = ISIGN(1,K)*ISIGN(1,KTEST)*(ISHIFT(I11)+IPH2) - IDEG(L) IPH3 = MOD(IPH3,360) IF (IPH3 .LE. 0) IPH3 = IPH3 + 360 IF (ITAB(IR3+6) .GT. 32000) GOTO 260 ITAB(IR3+4) = ITAB(IR3+4) + IWEE*ISCT(450-IPH3)/1000000 ITAB(IR3+5) = ITAB(IR3+5) + IWEE*ISCT(IPH3)/1000000 ITAB(IR3+6) = ITAB(IR3+6) + IWEE/1000 260 CONTINUE 270 CONTINUE 280 CONTINUE RETURN END SUBROUTINE STARTS (ICYC) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH, SWIPRI EQUIVALENCE (SWIPRI, SWITCH(10)) COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 EQUIVALENCE (LIS1, IFILE( 7)) EQUIVALENCE (LIS2, IFILE( 8)) EQUIVALENCE (IBINDO, IFILE(13)) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 PARAMETER (ISIZ = 59876) INTEGER *2 ITAB(ISIZ) CHARACTER LITOUT *38 DIMENSION IHKL(3) COMMON / EPWCO / IP1, IPHS, IREST, IT, W1, WS, E1, E2, EL, EEE PARAMETER (MAXBUF = 198) DIMENSION BUFDOP(MAXBUF), FITDOP(9) DATA NLINPR / 0 / CALL BINIFF (1, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP) ISTO4 = MARKA4 LLMAX = MAXA4 - INCA4 NSPEC = 0 NGEN = 0 NFLIP = 0 NSHIFT = 0 XNUM = 0.0 XDEN = 0.0 IIASUM = 0 IISSUM = 0 IIASN = 0 JCYC = ICYC - 1 IF (.NOT. SWIPRI) GOTO 210 WRITE (LIS2, 200) JCYC 200 FORMAT (/, '0In cycle ', I2, ' the following reflections had', * ' shifts of more than 45 degress', * ' (max. 100 refl. printed):', /, '0', * 3 (' H K L Eold Enew Pold Pnew Wnew '), /) NLINPR = 0 CHOUT = '(3A38)' CALL LINPRX (LIS2, LITOUT, 38, 3) 210 DO 310 NCOUNT=MCT,NCT,ICR CALL BINIFF (0, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP) IF (KENDOP .LT. 0) GOTO 320 CALL KERF2I (FITDOP(1), IHKL(1), 3) E1 = FITDOP(4) EL = E1 E2 = FITDOP(5) IP1 = NINT(FITDOP(6)) IPHS = IP1 W1 = FITDOP(7) IT = NINT(FITDOP(8)) IREST = NINT(FITDOP(9)) EOLD = ITAB(NCOUNT+7) / 100.0 EWOLD = ITAB(NCOUNT+2) / 100.0 WOLD = EWOLD / EOLD IPHO = ITAB(NCOUNT+3) ICS4 = ITAB(NCOUNT+4) ICS5 = ITAB(NCOUNT+5) ICS6 = ITAB(NCOUNT+6) IF (ICS4.EQ.0 .AND. ICS5.EQ.0 .AND. ICS6.EQ.0) THEN IDABS = 0 EL = EOLD WS = WOLD IPHS = IPHO GOTO 265 ENDIF XEE = EOLD / 10. AEE = ITAB(NCOUNT+4) * XEE BEE = ITAB(NCOUNT+5) * XEE FEE = ITAB(NCOUNT+6) * XEE EEE = SQRT(AEE*AEE + BEE*BEE) XNUM = XNUM + EEE XDEN = XDEN + FEE WS = (TANH(EEE/E000R))**2 IF (EEE.LT.0.01 .OR. WS.LT.0.01) GOTO 260 PHS = 57.29 * ATAN2(BEE,AEE) IF (PHS .LT. 0.) PHS = PHS + 360. IPHS = PHS + 0.5 IF (IT.GT.1 .OR. WOLD.LT.0.1) GOTO 250 IF (IDC3.EQ.1 .OR. (180-IPHO)*(180-IPHS).GT.0) GOTO 220 IF (MIN0(IPHS, 360-IPHS, IABS(180-IPHS)).GT.30) GOTO 250 IPHS = 180 * MOD((IPHS+90)/180, 2) IF (IPHS.EQ.0 .AND. IPHO.GT.180) IPHS = 358 220 CALL PHDIF (IPHS, IPHO, II, IIA) IF (PSQ .LT. 0.20) * IPHS=MOD(360+IPHO+ISIGN(MIN0(IIA,MAX1(47.,80.-10.*WOLD)),II),360) IF (IDC3 .EQ. 1) GOTO 250 IIS = MIN0 (IPHS, 360-IPHS) IF (IDC3 .EQ. 2) IIS = MIN0 (IIS, IABS(180-IPHS)) IIA = MIN0 (IPHO, 360-IPHO) IF (IDC3 .EQ. 2) IIA = MIN0 (IIA, IABS(180-IPHO)) IIASUM = IIASUM + IIA IISSUM = IISSUM + IIS IIASN = IIASN + 1 IF (IIS.GE.IIA .OR. IIS.GE.45) GOTO 250 IF (IISSUM/IIASN .LT. 35) IPHS = ((IPHS+IPHO)/180) * 90 + 45 IF (IIA .GT. 45) GOTO 250 IF (IIA .LT. 20) GOTO 240 IPHS = (IPHO+IPHS) / 2 GOTO 250 240 IPHS = IPHO + ISIGN(15, 90 - MOD(IPHO,180)) 250 CALL EPW 260 CALL PHDIF (IPHS, IPHO, IDIF, IDABS) IF (WOLD .LT. 0.1) IDABS = 0 265 IF (IT .GT. 1) GOTO 270 NGEN = NGEN + 1 NSHIFT = NSHIFT + IDABS E2AG(ICYC) = E2AG(ICYC) + EL*EL GOTO 280 270 IF (IDABS .GT. 90) NFLIP = NFLIP + 1 NSPEC = NSPEC + 1 E2CG(ICYC) = E2CG(ICYC) + EL*EL 280 IF (IDABS.LT.45 .OR. .NOT.SWIPRI) GOTO 290 IF (SWIPRI .AND. NLINPR.LT.100) THEN NLINPR = NLINPR + 1 WRITE (LITOUT, FMT='(1X, 3I3, 2F5.2, 2(I4,''.''), F6.3, 2X)') * IHKL, EOLD, EL, IPHO, IPHS, WS CALL LINPRX (0, LITOUT, 38, 3) ENDIF 290 ITAB(NCOUNT+2) = 100.0*EL*AMAX1(W1,WS) + 0.5 ITAB(NCOUNT+3) = IPHS ITAB(NCOUNT+4) = 0 ITAB(NCOUNT+5) = 0 ITAB(NCOUNT+6) = 0 ITAB(NCOUNT+7) = 100.*EL + 0.5 IF (ICYC .LT. NC) GOTO 300 ITAB(NCOUNT+4) = IP1 ITAB(NCOUNT+5) = IREST 300 IF (EL .LT. ESTART(ICYC)) GOTO 310 IF (ISTO4 .GT. LLMAX) GOTO 310 CALL IITAB4 (IHKL, NCOUNT) 310 CONTINUE 320 IF (SWIPRI) CALL LINPRX (-1, LITOUT, 38, 3) IF (ISTO4 .GT. LLMAX) WRITE (LIS1, 330) ICYC 330 FORMAT(' **** WARNING: the basic set for cycle', I2, * ' is not complete; table ITAB is too small') MS = (ISTO4-MARKA4) / INCA4 IF (NGEN .GT. 0) NSHIFT = FLOAT(NSHIFT)/NGEN + .5 IF (IICENT .EQ. 1) THEN WRITE (LIS2, 340) JCYC, NGEN, NSHIFT, NFLIP, NSPEC 340 FORMAT (' Statistics for cycle ', I3, ':', /, * I5, ' general reflections gave average phase shift of ', * I4, ' degrees', /, I5, ' special reflections out of', * ' a total of', I5, ' shifted by 180 degrees') ELSE WRITE (LIS2, 342) JCYC, NFLIP, NSPEC 342 FORMAT (' Statistics for cycle ', I3, ':', /, * I5, ' reflections out of a total of', * I5, ' gave a phase shift of 180 degrees') ENDIF IF (XDEN .LT. 0.00001) GOTO 355 XDEN = XNUM / XDEN WRITE (LIS1, FMT='('' Cycle'', I3, '': Sigma2 - consistency '', * F6.3)') JCYC, XDEN WRITE (LIS2, FMT='('' Sigma2 - consistency: '', F6.3)') XDEN 355 IF (IDC3 .EQ. 1) GOTO 370 IIASN = MAX0 (1, IIASN) IIASUM = IIASUM / IIASN IISSUM = IISSUM / IIASN WRITE (LIS2, 360) IIASUM, IISSUM 360 FORMAT ('0Average deviation from 0 degrees (or 180 degrees)' / * ' for phases used in the last cycle: ', I3 , ' degrees '/ * ' for new phases (before resetting): ', I3 , ' degrees ') 370 CALL KETIME (LIS2) IF (ICYC .LT. NC) WRITE (LIS2, 380) MS, ICYC 380 FORMAT('0There are', I5, ' reflections in the basic set', * ' for cycle', I3) RETURN END SUBROUTINE ORSHIF (HKL, TO, P1, P2, PL, KORIS) DIMENSION HKL(3), TO(3) PHT = 0.0 DO 110 I=1,3 110 PHT = PHT + TO(I)*HKL(I) PHT = AMOD(PHT,1.) * 360. IF (PHT .LT. 0.0) PHT = PHT + 360. IF (KORIS .NE. 1) GOTO 120 P1 = P1 - PHT P2 = P2 - PHT IF (P1 .LT. 0.0) P1 = P1 + 360. IF (P2 .LT. 0.0) P2 = P2 + 360. GOTO 130 120 PL = PL - PHT IF (PL .LT. 0.0) PL = PL + 360. 130 RETURN END SUBROUTINE PSEUDO (TO) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH, EXPAND EQUIVALENCE (EXPAND, SWITCH(23)) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION TO(3), RSYMM(3,3,24) NNSYMM = NSYMM IF (EXPAND) NNSYMM = 1 CALL KERI2F (IRSYMM, RSYMM, 9*NNSYMM) DO 130 K=1,NNSYMM DO 130 I=1,3 TMA = 0.0 DO 120 J=1,3 120 TMA = TMA + RSYMM(I,J,K)*TO(J) 130 TSYMM(I,K) = TMA + TSYMM(I,K) - TO(I) RETURN END SUBROUTINE IITAB4 (IHKL, K) DIMENSION IHKL(3) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 PARAMETER (ISIZ = 59876) INTEGER *2 ITAB(ISIZ) ISTO4 = ISTO4 + INCA4 ITAB(ISTO4+1) = IHKL(1) ITAB(ISTO4+2) = IHKL(2) ITAB(ISTO4+3) = IHKL(3) ITAB(ISTO4+4) = K - MCT RETURN END INTEGER FUNCTION INPACK (I) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 PARAMETER (ISIZ = 59876) INTEGER *2 ITAB(ISIZ) DIMENSION I(3) IF (MCTLAT .GT. 1) GOTO 100 INPACK = MCH*I(1) + MCK*I(2) + I(3) RETURN 100 K2 = I(2) K3 = I(3) GOTO (1, 2, 2, 4, 2, 6, 7 ), MCTLAT 2 IF (K3 .NE. 0) K3 = (K3 + ISIGN(1,K3))/2 GOTO 1 6 IF (K2 .NE. 0) K2 = (K2 + ISIGN(1,K2))/2 GOTO 2 7 IF (K3 .NE. 0) K3 = (K3 + ISIGN(2,K3))/3 GOTO 1 4 IF (K2 .NE. 0) K2 = (K2 + ISIGN(1,K2))/2 1 INPACK = MCH*I(1) + MCK*K2 + K3 RETURN END SUBROUTINE XUNPAK (IPACK, IHKL) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 PARAMETER (ISIZ = 59876) INTEGER *2 ITAB(ISIZ) DIMENSION IHKL(3) EQUIVALENCE (MAXHKL(1),MAXH), (MAXHKL(2),MAXK), (MAXHKL(3),MAXL) I1 = IPACK + MCT I2 = I1 / MCH IHKL(1) = I2 - MAXH I1 = I1 - I2*MCH I2 = I1 / MCK IHKL(2) = I2 - I34 IHKL(3) = I1 - I2*MCK - I35 GOTO (9, 2, 3, 4, 5, 7, 6 ), MCTLAT 2 KH = IABS(IHKL(2)) GOTO 110 3 KH = IABS(IHKL(1)) GOTO 110 5 KH = IABS(IHKL(1)+IHKL(2)) 110 IF (IHKL(3) .NE. 0) IHKL(3) = 2*IHKL(3) - ISIGN(MOD(KH,2),IHKL(3)) GOTO 9 7 KH = IHKL(3)*3 GOTO (120, 9, 130), KH 120 IHKL(3) = KH + MOD(300+IHKL(1)-IHKL(2),3) GOTO 9 130 IHKL(3) = KH - MOD(300-IHKL(1)+IHKL(2),3) GOTO 9 6 KH = IABS(IHKL(1)) IF (IHKL(3) .NE. 0) IHKL(3) = 2*IHKL(3) - ISIGN(MOD(KH,2),IHKL(3)) 4 KH = IABS(IHKL(1)) IF (IHKL(2) .NE. 0) IHKL(2) = 2*IHKL(2) - ISIGN(MOD(KH,2),IHKL(2)) 9 RETURN END FUNCTION IGROUP (IHKL) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION IHKL(3), ICODE(24) DATA ICODE / 1,2,3,4,3,4,1,2,1,2,3,4,2,1,4,3,1,2,2,1,3,4,4,3 / IGROUP = 0 DO 100 I=1,3 100 IGROUP = IGROUP + IABS(MOD(IHKL(I),2))*2 **I IGROUP = IGROUP/2 +1 GOTO (3, 3, 3, 2, 2, 5, 5, 4, 4, 4, 4, 4, 5, 5), ILAUE 2 I = 8*(IUNIQ-1) + IGROUP IGROUP = ICODE(I) 3 RETURN 4 IGROUP = IABS(MOD(IHKL(IUNIQ),2)) +1 RETURN 5 IGROUP = 0 DO 110 I=1,3 110 IGROUP = IGROUP + IHKL(I) IGROUP = IABS(MOD(IGROUP,2)) + 1 RETURN END SUBROUTINE SYMEQ (IHKL, N) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH, EXPAND EQUIVALENCE (EXPAND, SWITCH(23)) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 PARAMETER (ISIZ = 59876) INTEGER *2 ITAB(ISIZ) COMMON / KLAD / IC(4,48), IS(48) DIMENSION ICODE(13), IHKL(3), ITEMP(24) DATA ICODE / 1, 0, 2, 3, 4, 0, 5, 0, 6, 7, 8, 0, 1 / NNSYMM = NSYMM IF (EXPAND) NNSYMM = 1 M = N N = 1 CALL KERNZI (0, ITEMP, 24) DO 150 I=1,NNSYMM XTEST = 0.0 DO 120 K=1,3 IC(K,N) = 0 DO 110 L=1,3 110 IC(K,N) = IC(K,N) + IHKL(L)*IRSYMM(L,K,I) 120 XTEST = XTEST - IHKL(K)*TSYMM(K,I) IC(4,N) = INPACK(IC(1,N)) ITEMP(N) = IABS(IC(4,N)) IF (N.EQ.1) GOTO 140 K = N - 1 DO 130 L=1,K 130 IF (ITEMP(L) .EQ. ITEMP(N)) GOTO 150 140 XTEST = XTEST - IFIX(XTEST) IF (XTEST .LT. -0.01) XTEST = XTEST + 1.0 J = IFIX(12.*XTEST+0.01) + 1 IS(N) = ICODE(J) N = N + 1 150 CONTINUE N = N - 1 IF (M .EQ. 1) GOTO 170 DO 160 J=1,N DO 160 I=1,4 160 IC(I,J+N) = -IC(I,J) 170 RETURN END SUBROUTINE DD38 COMMON / SINCOS / IDEG(8), ISCT INTEGER*2 ISCT(450) IDEG(1) = 0 IDEG(2) = 60 IDEG(3) = 90 IDEG(4) = 120 IDEG(5) = 180 IDEG(6) = 240 IDEG(7) = 270 IDEG(8) = 300 P = 0.0 DO 100 I=1,90 P = P + 0.0174532925 IP = SIN(P)*1000. + 0.5 ISCT(I) = IP ISCT(180-I) = IP ISCT(180+I) = -IP ISCT(360-I) = -IP ISCT(360+I) = IP 100 CONTINUE ISCT(360) = 0 ISCT(180) = 0 RETURN END SUBROUTINE PHDIF (IPHS, IP, IDIF, IDABS) IDIF = IPHS-IP IF (IDIF .LT. -179) IDIF = IDIF + 360 IF (IDIF .GT. 180) IDIF = IDIF - 360 IDABS = IABS(IDIF) RETURN END SUBROUTINE EPW COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 PARAMETER (ISIZ = 59876) INTEGER *2 ITAB(ISIZ) COMMON / EPWCO / IP1, IPHS, IREST, IT, W1, WS, E1, E2, EL, EEE CALL PHDIF (IPHS, IP1, IDIF, IDABS) IF (IREST .LT. 100) GOTO 220 IF (IT .EQ. 1) GOTO 200 EEE = ABS (EEE * COS(IDIF/57.29)) WS = TANH (EEE/E000R)**2 IDIF = 0 IF (WS.LT.W1 .OR. EEE.LT.0.01) GOTO 250 IF (IDABS .LT. 90) GOTO 250 IDIF = 180 EL = E2 GOTO 250 200 IF (IDIF .EQ. 0) GOTO 250 IF (W1 .LT. 0.1) GOTO 210 IF (WS .LT. W1) IDIF = IDIF*WS/W1 + 0.5 210 COSD = COS(IDIF/57.29) * (E2-E1) EL = 0.5 * ABS(COSD - SQRT(COSD**2+4.*E1*E2)) GOTO 250 220 IF (IT .NE. 1) GOTO 240 IF (IDABS .LT. IREST) GOTO 230 IDIF = ISIGN (IREST,IDIF) EEE = ABS (EEE * COS((IDABS-IREST)/57.29)) WS = TANH (EEE/E000R)**2 IF (WS.LT.W1 .OR. EEE.LT.0.01) GOTO 240 EL = SQRT (E1*E2) GOTO 250 230 IF (IDIF .EQ. 0) GOTO 260 IF (WS .LT. W1) GOTO 240 COSD = COS (IDIF/57.29) * (E2+E1) EL = 0.5 * ABS (COSD - SQRT(COSD**2-4.*E1*E2)) GOTO 250 240 IDIF = 0 250 IPHS = IP1 + IDIF IF (IPHS .GE. 360) IPHS = IPHS - 360 IF (IPHS .LT. 0) IPHS = IPHS + 360 260 CONTINUE RETURN END SUBROUTINE LOCCEN (KEY, CENTER) DIMENSION CENTER(3) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH, EXPAND EQUIVALENCE (EXPAND, SWITCH(23)) EQUIVALENCE (IATOMS, IFILE(1)) EQUIVALENCE (LIS1, IFILE(7)) EQUIVALENCE (LIS2, IFILE(8)) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 PARAMETER (ISIZ = 59876) INTEGER *2 ITAB(ISIZ) PARAMETER (NSLOT = 10, MAXAT = 993) COMMON /LOCPC1/ * ATXYZ(NSLOT, MAXAT), IZAT(MAXAT), * XY(3,400), NIZ(400), NDEL(400), SYMXYZ(3), * DLIM(6), CEN2(3) COMMON /LOCPC2/ * ATNAME CHARACTER *6 ATNAME(MAXAT) IF (KEY .GT. 0) RETURN IF (IICENT .EQ. 2) RETURN NSLOC = NSYMM IF (EXPAND) NSLOC = 1 IF (NSLOC .NE. NSYMM) THEN WRITE (LIS2, 200) 200 FORMAT (/' Search for LOCCEN in triclinic symmetry:' / * ' Results correct only after execution of program EXPAND') ELSE WRITE (LIS2, 210) 210 FORMAT ('0Search for LOCCEN (symm.center in model struct.?))') ENDIF CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ) IF (KINQ .NE. 0) CALL KERROR ('No ATOMS file found', 0, 'LOCCEN') CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT) CALL FILCLO (IATOMS, 'KEEP') N = NAT * NSLOC * NLATT IF (N .LE. 400) GOTO 260 WRITE (LIS1, 240) N WRITE (LIS2, 240) N 240 FORMAT (' No search for LOCCEN: too many atoms in the unit cell'/ * ' Allowed: maximum 400 , input (symmetry inluded):', I5 / * ' If enantiomorph problem: do supply a LOCCEN card') RETURN 260 DO 270 I=1,3 DLIM(I) = 0.20 / CELL(I) 270 DLIM(I+3) = 1.0 - DLIM(I) K = 1 DO 320 LA=1,NAT DO 320 LL=1,NLATT DO 320 LS=1,NSLOC DO 280 I=1,3 XY(I,K) = TSYMM(I,LS) + TLATT(I,LL) DO 280 J=1,3 280 XY(I,K) = XY(I,K) + ATXYZ(J,LA)*IRSYMM(I,J,LS) DO 310 I=1,3 290 IF (XY(I,K) .GT. 0.5) GOTO 300 IF (XY(I,K) .GT. -.5) GOTO 310 XY(I,K) = XY(I,K) + 1.0 GOTO 290 300 XY(I,K) = XY(I,K) - 1.0 GOTO 290 310 CONTINUE NIZ(K) = IZAT(LA) 320 K = K + 1 DO 410 L=1,N IF (IABS(NIZ(1)-NIZ(L)) .GT. 2) GOTO 410 DO 340 I=1,3 CEN2(I) = XY(I,1) + XY(I,L) IF (CEN2(I) .GT. 0.7) CEN2(I) = CEN2(I) - 1.0 IF (CEN2(I) .LE. -.3) CEN2(I) = CEN2(I) + 1.0 340 CENTER(I) = CEN2(I) J = 2 CALL KERNZI (0, NDEL, N) NDEL(1) = 1 NDEL(L) = 1 DO 390 LC=1,N IF (NDEL(LC) .EQ. 1) GOTO 390 DO 350 I=1,3 350 SYMXYZ(I) = CEN2(I) - XY(I,LC) DO 380 LR=1,N IF (NDEL(LR) .EQ. 1) GOTO 380 IF (IABS(NIZ(LR)-NIZ(LC)) .GT. 2) GOTO 380 DO 360 I=1,3 DIST = ABS(SYMXYZ(I) - XY(I,LR)) IF (DIST.GT.DLIM(I) .AND. DIST.LT.DLIM(I+3)) GOTO 380 360 CONTINUE J = J + 2 DO 370 I = 1,3 DIST = XY(I,LC) + XY(I,LR) IF (DIST-CEN2(I) .LT. -.1) DIST = DIST + 1.0 IF (DIST-CEN2(I) .GT. 0.1) DIST = DIST - 1.0 370 CENTER(I) = CENTER(I) + DIST NDEL(LC) = 1 NDEL(LR) = 1 GOTO 390 380 CONTINUE GOTO 410 390 CONTINUE DO 400 I=1,3 400 CENTER(I) = CENTER(I) / J GOTO 430 410 CONTINUE WRITE (LIS2, 420) 420 FORMAT (' No center of symmetry found') RETURN 430 WRITE (LIS1, 440) (CENTER(I), I=1,3) 440 FORMAT (' Center of symmetry found at ', 3F7.4) KEY = 1 RETURN END SUBROUTINE LINPRX (KEY, LITOUT, LOUT, NIT) CHARACTER LITOUT *(*) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 CHARACTER PRFORM *72 PARAMETER (MAXLIN = 20, MAXCHA = 100) CHARACTER LITLIN(MAXLIN) *100 DATA LITNIT, NITMAX, IPR / 0, 0, 0/ IF (KEY) 230, 220, 200 200 IPR = KEY PRFORM = CHOUT CHOUT = ' ' NITMAX = NIT IF (NITMAX .GT. MAXLIN) CALL KERNER (4, 'LINPRX') IF (LOUT .GT. MAXCHA) CALL KERNER (4, 'LINPRX') 210 CALL KERNZ1 (' ', LITLIN, NIT) LITNIT = 0 RETURN 220 IF (LITNIT+1 .GT. NITMAX) THEN WRITE (IPR, FMT=PRFORM) (LITLIN(ILIT), ILIT=1,LITNIT) CALL KERNZ1 (' ', LITLIN, NITMAX) LITNIT = 0 ENDIF LITNIT = LITNIT + 1 LITLIN(LITNIT) = LITOUT RETURN 230 IF (LITNIT .GT. 0) * WRITE (IPR, FMT=PRFORM) (LITLIN(ILIT), ILIT=1,LITNIT) GOTO 210 END SUBROUTINE DACOP COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH EQUIVALENCE (LIS2, IFILE(8)) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 PARAMETER (ISIZ = 59876) INTEGER *2 ITAB(ISIZ) COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ5 = 10000) INTEGER *2 ITAB5(5*ISIZ5) LOGICAL REDUS COMMON / KLADC / CHAR(12) CHARACTER CHARR(12) *1, CHAR *1 DATA CHARR / 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', * '-', ' '/ DO 110 I=1,5*ISIZ5 110 ITAB5(I) = 0 INCA5 = 5 DO 120 I=1,12 120 CHAR(I) = CHARR(I) II = (MAXA4-ISTO4) / 50 I = MS IF (IDC.EQ.1 .AND. I.GT.200) I = 100 + I/2 MAXA4N = MARKA4 + I*INCA4 I5 = I / 2 I5 = MIN0(I5,II,MAXT) + 14 MAXT = MIN0(I5,MAXT) IF (MS .LT. 500) I5 = 500 - MS MAXA4 = MAXA4N + I5 * INCA4 WRITE (LIS2, FMT='('' Limitations:'')') IF (IDC .EQ. 1) WRITE (LIS2, 140) I 140 FORMAT (' New basic set with numeric phases: ', I5) WRITE (LIS2, 150) I5, II 150 FORMAT (' in basic set with symbolic phases: ', I5/ * ' maximum number of symbolic phases: ', I5) RETURN END SUBROUTINE DAMAIN COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH EQUIVALENCE (LIS1, IFILE(7)) EQUIVALENCE (LIS2, IFILE(8)) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ = 59876, ISIZ5 = 10000) INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5) LOGICAL REDUS DIMENSION KPGE(8), KPG(8) JSYMB = 0 JOLD = 0 JSMAX = 10 IF (IPSQ .EQ. 1) JSMAX = 15 DO 210 K=MCT,NCT,ICR IF (ITAB(K+2) .GE. 0) GOTO 200 ITAB(K+4) = -(1000.*ITAB(K+2)) / ITAB(K+7) GOTO 210 200 WNE = ITAB(K+4) ITAB(K+4) = SQRT(WNE) * (ITAB(K+7)-ITAB(K+2)) 210 CONTINUE ISTA4 = ISTO4 + INCA4 ISTO5 = 0 WRITE (LIS2, 220) 220 FORMAT (' Ambiguity choices', /, 5X, 'H K L E1 Symbol') DO 270 KK=1,2 230 CALL KERNZI (0, KPGE(1), 8) CALL KERNZI (0, KPG(1), 8) KTEST = 0 DO 240 K=MCT,NCT,ICR IF (IPSQ.EQ.1 .AND. IICENT.EQ.1 .AND. ITAB(K+5).NE.-1) GOTO 240 IF (ITAB(K+2).LT.0 .OR. ITAB(K+6).LT.0) GOTO 240 IF (IPSQ.EQ.0 .AND. ITAB(K+2).GT.2 .AND. KK.EQ.2) GOTO 240 IPG = ITAB(K+6) IF (IPG2(IPG).LT.0 .AND. KK.EQ.1) GOTO 240 IF (ITAB(K+4) .LE. KPGE(IPG)) GOTO 240 KPGE(IPG) = ITAB(K+4) KPG(IPG) = K KTEST = KTEST + 1 240 CONTINUE DO 250 IPG=1,8 IF (KPG(IPG) .LE. 0) GOTO 250 K = KPG(IPG) IF (IICENT.EQ.2 .OR. ITAB(K+5).EQ.-1) CALL DACAS (K) IF (ITAB(K+7) .GT. 0) ITAB(K+6) = -1 IF (JSYMB .EQ. JSMAX) GOTO 280 250 CONTINUE IF (JOLD .EQ. JSYMB) GOTO 260 JOLD = JSYMB GOTO 230 260 IF (JSYMB .GT. 0) GOTO 280 IF (KTEST.EQ.0 .AND. KK.EQ.2) GOTO 275 270 CONTINUE 275 IF (JSYMB .EQ. 0) GOTO 300 280 IF (JSYMB .GT. 10) JSYMB = 10 DO 290 K=MCT,NCT,ICR IF (ITAB(K+7) .GT. 0) ITAB(K+6) = 0 IF (ITAB(K+2) .GT. 0) ITAB(K+4) = 0 290 CONTINUE 300 IF (JSYMB .EQ. 0) CALL KERROR ('No symbols', 0, 'DAMAIN') WRITE (LIS1, 310) JSYMB WRITE (LIS2, 310) JSYMB 310 FORMAT (' Number of ambiguity symbolic choices (primary', * ' set):', I6) RETURN END SUBROUTINE DACAS (K) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH EQUIVALENCE (LIS2, IFILE(8)) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ = 59876, ISIZ5 = 10000) INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5) LOGICAL REDUS COMMON / KLADC / CHAR(12) CHARACTER CHAR *1 DIMENSION IHKL(3), ISTOR(10) IPACK = ITAB(K+1) CALL XUNPAK (IPACK, IHKL) E1 = ITAB(K+7) / 100. IF (JSYMB .LT. 2) GOTO 200 CALL GENERB (IHKL, K, ISW) IF (ISW .EQ. -1) RETURN 200 IF (IPSQ .EQ. 0) GOTO 220 EW = ITAB(K+2) / 100. W1 = EW / E1 DO 210 I7=1,7 210 ISTOR(I7) = ITAB(K+I7) ISTOR(4) = W1 CALL KERNAI (IHKL, ISTOR(8), 3) CALL REDSYM (0, ISTOR, K) 220 JSYMB = JSYMB + 1 IF (JSYMB .GT .10) RETURN CALL IITAB4 (IHKL, K) ITAB(K+7) = -ITAB(K+7) ITAB(K+2) = ITAB(K+7) ITAB(K+3) = 0 ITAB(K+4) = 1000 ISTO5 = ISTO5 + INCA5 ITAB(K+6) = ISTO5 / 5 ITAB5(ISTO5+1) = 32767 ITAB5(ISTO5+4) = 0 ITAB5(ISTO5+5) = JSYMB IF (IDC .EQ. 1) GOTO 240 WRITE (LIS2, 230) IHKL, E1, CHAR(JSYMB) 230 FORMAT (2X, 3I4, F7.2, 4X, A1, I8) RETURN 240 WRITE (LIS2, 230) IHKL, E1, CHAR(JSYMB), ITAB(K+5) RETURN END SUBROUTINE GENERB (IHKL, IR1, ISW) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ = 59876, ISIZ5 = 10000) INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5) LOGICAL REDUS COMMON / KLAD / ICODE(4,48), ISHIFT(48) DIMENSION IHKL(3), IHKL3(3) EQUIVALENCE (IHKL3(1), JJH1), (IHKL3(2), JJH2), (IHKL3(3), JJH3) EQUIVALENCE (MAXHKL(1),MAXH), (MAXHKL(2),MAXK), (MAXHKL(3),MAXL) DATA K / 0 / NEQ = 2 CALL SYMEQ (IHKL, NEQ) NEQ2 = NEQ * 2 DO 240 I42=ISTA4,ISTO4,INCA4 JH1 = ITAB(I42+1) JH2 = ITAB(I42+2) JH3 = ITAB(I42+3) IR2 = ITAB(I42+4) + MCT J = ITAB(IR2+1) DO 230 I11=1,NEQ2 IF (MCTLAT .GT. 1) GOTO 200 I = ICODE(4,I11) KTEST = I + J K = IABS(KTEST) IF (K .EQ. 0) GOTO 230 IF (K .GT. MCT) GOTO 230 IF (ITAB(K) .EQ. 0) GOTO 230 200 JJH1 = ICODE(1,I11) + JH1 IF (IABS(JJH1) .GT. MAXH) GOTO 230 JJH2 = ICODE(2,I11) + JH2 IF (IABS(JJH2) .GT. MAXK) GOTO 230 JJH3 = ICODE(3,I11) + JH3 IF (IABS(JJH3) .GT. MAXL) GOTO 230 IF (MCTLAT .EQ. 1) GOTO 210 KTEST = INPACK(IHKL3) K = IABS(KTEST) IF (K .EQ. 0) GOTO 230 IF (ITAB(K) .EQ. 0) GOTO 230 210 K = ITAB(K) LTEST = IABS(K) L = LTEST / 4096 IR3 = (LTEST-L*4096-1)*ICR + MCT IF (IR3 .EQ. IR1) GOTO 250 IR3 = IR3 - MCT DO 220 I=ISTA4,ISTO4,INCA4 IRB = ITAB(I+4) IF(IR3 .EQ. IRB) GOTO 250 220 CONTINUE 230 CONTINUE 240 CONTINUE ISW = 0 RETURN 250 ISW = -1 RETURN END SUBROUTINE DCMAIN COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH, SWIPRI EQUIVALENCE (SWIPRI, SWITCH(10)) COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IBINDO, IFILE(13)) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ = 59876, ISIZ5 = 10000) INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5) LOGICAL REDUS PARAMETER (MAXBUF = 198) DIMENSION FITDOP(9), BUFDOP(MAXBUF) DIMENSION IHKL(3), KARR(100) DIMENSION CC(25), ICC(25), IB(25) CHARACTER LITOUT *32 CALL KERNZA (0., CC, 25) CALL KERNZI (0, ICC, 25) CALL GENER NAVG = 0 CAVG = 0.0 NAVG2 = 0 CAVG2 = 0.0 CALL BINIFF (1, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP) DO 240 K=MCT,NCT,ICR CALL BINIFF (0, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP) IF (KENDOP .LT. 0) GOTO 250 E1 = FITDOP(4) W1 = FITDOP(7) IT = FITDOP(8) PHREST = FITDOP(9) AEE = ITAB(K+4) BEE = ITAB(K+5) SEE = ITAB(K+6) ITAB(K+4) = W1 * 1000. ITAB(K+5) = 0 ITAB(K+6) = 0 IF (IT .GT. 1) GOTO 230 IF (PHREST.LT.150. .OR. E1.GT.3.999) GOTO 240 IF (W1 .LT. 0.16) GOTO 200 IP1 = ITAB(K+3) IP1 = MOD(IP1,180) CALL PHDIF (IP1, 90, IDIF, IDABS) IF (IDABS .GT. 45) GOTO 200 ITAB(K+4) = ITAB(K+4) + 1000 GOTO 240 200 EEE = SQRT(AEE*AEE+BEE*BEE) IF (EEE .LT. 1.) EEE = 1. QEE = SEE / EEE IF (QEE .GT. 5.) QEE = 5. C = QEE * E1 * (SEE-EEE)/10. NAVG = NAVG + 1 IF (C .GT. 32767.) C = 32767. CAVG = CAVG + C IF (C .LT. 1.) GOTO 240 ITAB(K+5) = C + 0.5 IF (W1 .GT. 0.9) GOTO 240 NAVG2 = NAVG2 + 1 CAVG2 = CAVG2 + C C = C * E1 IF (C .LE. CC(25)) GOTO 240 II = 25 210 JJ = II - 1 IF (C .LE. CC(JJ)) GOTO 220 CC(II) = CC(JJ) ICC(II) = ICC(JJ) II = JJ IF (II .GT. 1) GOTO 210 220 CC(II) = C ICC(II) = K GOTO 240 230 ITAB(K+5) = -IT 240 CONTINUE 250 CONTINUE CAVG = CAVG / NAVG IF (NAVG2 .GT. 0) CAVG2 = CAVG2 / NAVG2 WRITE (LIS2, 260) CAVG, NAVG, CAVG2, NAVG2 260 FORMAT(' The averaged value of the enantiomorph discriminator', * ' (C): ', F7.2,/,3X, '(calculated on', I5, ' reflections)', * /, ' ', * ' (C): ', F7.2,/,3X, '(calculated on', I5, * ' unphased reflections)') NAVG = CAVG/2.0 + 0.5 NAVG2 = CAVG2/2.0 + 0.5 IF (NAVG2 .GT. 0) GOTO 280 NAVG = 0 WRITE (LIS2, 270) 270 FORMAT ('0=== C-formula not valid === use: E1/W1**2 ===') IDC3 = 3 280 NREFM = (NCT-MCT) / ICR / 5 NREFM = MIN0(NREFM,80) NREFMA = (MAXA4N - MARKA4) / INCA4 IW = 990 IESTR = 80 NN = 0 NN2 = 0 DO 290 K=MCT,NCT,ICR IF (ITAB(K+4).LT.500 .OR. ITAB(K+5).GT.NAVG) GOTO 290 IF (ITAB(K+4) .GE. 990) NN2 = NN2 + 1 NN = NN + 1 290 CONTINUE IF (NN2 .GT. NREFMA) GOTO 310 IF (NN2 .GE. NREFM) GOTO 330 IW = 500 IF (NN .LE. NREFM) GOTO 330 CALL VALDIS (-1, 500., 1000., KARR, 100, NUMA4) DO 300 K=MCT,NCT,ICR IF (ITAB(K+4).LT.500 .OR. ITAB(K+5).GT.NAVG) GOTO 300 W1 = ITAB(K+4) CALL VALDIS (0, W1, 0., KARR, 100, NUMA4) 300 CONTINUE CALL VALDIS (NREFM, W1, 0., KARR, 100, NUMA4) IW = W1 + .5 GOTO 330 310 CALL VALDIS (-1, 80., 400., KARR, 100, NUMA4) DO 320 K=MCT,NCT,ICR IF (ITAB(K+4).LT.990 .OR. ITAB(K+5).GT.NAVG) GOTO 320 E1 = ITAB(K+7) CALL VALDIS (0, E1, 0., KARR, 100, NUMA4) 320 CONTINUE CALL VALDIS (NREFMA, E1, 0., KARR, 100, NUMA4) IESTR = E1 + .5 330 W1 = FLOAT(IW) / 1000. E1 = FLOAT(IESTR) / 100. WRITE (LIS2, 340) W1, E1 340 FORMAT ('0Select new basic set, W1min = ', F6.3, ' E1min = ',F5.2) IF (SWIPRI) THEN WRITE (LIS2, 350) 350 FORMAT ('0New basic set reflections with numeric phases', / * ' ', 4 (' H K L E1 P1 W1 C '), /) CHOUT = '(4A32)' CALL LINPRX (LIS2, LITOUT, 32, 4) ENDIF ISTO4 = MARKA4 DO 360 K=MCT,NCT,ICR IF (ITAB(K+7).LT.IESTR .OR. ITAB(K+4).LT.IW * .OR. ITAB(K+5).GT.NAVG) GOTO 360 IF (ISTO4 .GE. MAXA4N) GOTO 370 IP = ITAB(K+1) CALL XUNPAK (IP, IHKL) CALL IITAB4 (IHKL, K) ITAB(K+2) = -ITAB(K+2) IF (SWIPRI) THEN E1 = ITAB(K+7) / 100. IP1 = ITAB(K+3) W = ITAB(K+4) / 1000. IF (ITAB(K+4) .GT. 1000) W = W - 1. ICX = ITAB(K+5) WRITE (LITOUT, FMT='(1X, 3I3, F5.2, I4, ''.'', F5.2, I4, 3X)') * IHKL, E1, IP1, W, ICX CALL LINPRX (0, LITOUT, 32, 4) ENDIF 360 CONTINUE 370 IF (SWIPRI) CALL LINPRX (-1, LITOUT, 32, 4) NUMA4 = (ISTO4-MARKA4) / INCA4 WRITE (LIS2, 380) NUMA4 380 FORMAT ('0There are ', I5, ' reflections with numeric phases', * ' in the new basic set') NIB = 25 IF (NAVG .GT. 0) GOTO 430 IE4 = 399 383 CALL KERNZI (0, IB, 25) NIB = 0 DO 420 K=MCT,NCT,ICR IF (ITAB(K+4).GT.IW .OR. ITAB(K+5).LT.0) GOTO 420 IF (ITAB(K+7) .GT. IE4) GOTO 420 I = ITAB(K+4) I = ITAB(K+7) * 100000 / MAX0(10,I)**2 IF (I .LE. IB(25)) GOTO 420 NIB = MIN0 (NIB +1, 25) JJ = 25 DO 390 II=1,25 IF (I-IB(II)) 390, 390, 410 390 CONTINUE 400 IB(JJ) = IB(JJ-1) ICC(JJ) = ICC(JJ-1) JJ = JJ - 1 410 IF (II .LT. JJ) GOTO 400 IB(II) = I ICC(II) = K 420 CONTINUE IF (NIB .LT. 25) THEN WRITE (LIS2, 421) NIB 421 FORMAT (' Only ', I3, ' enant.discr. refl. accepted:') IF (NIB .GT. 0) WRITE (LIS2, 422) IB(NIB) 422 FORMAT (' the weakest having IE1 / IW1 =', I7) IF (NIB .GE. 15) GOTO 430 IF (IE4 .LT. 500) THEN IE4 = IE4 + 200 IW = IW * 2 WRITE (LIS2, FMT='('' try again ... ??'')') GOTO 383 ENDIF IF (NIB .GE. 1) GOTO 430 CALL KERROR ('No enant.discr.refl. found', 422, 'DCMAIN') ENDIF 430 DO 440 K=MCT,NCT,ICR IF (ITAB(K+4) .GT. 1000) ITAB(K+4) = ITAB(K+4) - 1000 440 CONTINUE ISTA4 = ISTO4 + INCA4 ISTO5 = 0 WRITE (LIS2, 450) 450 FORMAT ('0Enantiomorph discrimination reflections and', * ' assignement of symbols', /, 5X, * 'H K L E1 symbol C') JSYMB = 0 JSMAX = 10 IF (IPSQ .EQ. 1) JSMAX = 15 JSMAX = MIN0 (NIB, JSMAX) DO 460 I=1,NIB IF (JSYMB .EQ. JSMAX) GOTO 470 K = ICC(I) CALL DACAS (K) 460 CONTINUE 470 WRITE (LIS1, 480) JSYMB WRITE (LIS2, 480) JSYMB 480 FORMAT (' Number of ambiguity symbolic choices (primary', * ' set):', I6) RETURN END SUBROUTINE DACEND COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH EQUIVALENCE (IRD, IFILE(5)) EQUIVALENCE (IPR1, IFILE(6)) EQUIVALENCE (LIS2, IFILE(8)) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ = 59876, ISIZ5 = 10000) INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5) LOGICAL REDUS DIMENSION NLET(10), ISOL(10,2) CALL KETIME (LIS2) FAKWS = 1. REDUS = .FALSE. IF (IPSQ.EQ.1 .AND. JSYMB.GT.3) REDUS = .TRUE. 200 ISTA42 = ISTA4 CALL GENERC CALL REAR CALL KERNZI (0, NLET, 10) CALL KERNZI (1, NLET, JSYMB) CALL TACCEP (NLET, NTEMP) IF (NTEMP .LE. 0) GOTO 211 CALL KETIME (LIS2) IF (REDUS) THEN KRED = 0 CALL REDSYM (1, NLET, KRED) IF (KRED .EQ. 1) REDUS = .FALSE. GOTO 200 ENDIF CALL REAR2 CALL GENERC CALL REAR 211 CALL SYMREL (ISOL) IF (IPSQ .EQ. 0) GOTO 320 KBEST = ISOL(1,2) DO 260 J=1,JSYMB ISOL(J,1) = KB10X(J,KBEST) 260 ISOL(J,2) = 0 320 ILINK = 0 CALL XXLINK (ISOL, ILINK) CALL KETIME (LIS2) RETURN END SUBROUTINE REDSYM (KEY, ISTOR, K) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH EQUIVALENCE (LIS1, IFILE(7)) EQUIVALENCE (LIS2, IFILE(8)) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ = 59876, ISIZ5 = 10000) INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5) LOGICAL REDUS COMMON / KLADC / CHAR(12) CHARACTER CHAR *1 DIMENSION ISTOR(10), ISTOR1(11,15), IHKL(3) LOGICAL FIRST DATA FIRST / .FALSE. / DATA NSYMB, KTEST, ISMAX / 0, 0, 0 / IF (FIRST) GOTO 200 ISMAX = 1 KTEST = 0 NSYMB = 0 FIRST = .TRUE. 200 IF (KEY .EQ. 1) GOTO 210 NSYMB = NSYMB + 1 CALL KERNAI (ISTOR(1), ISTOR1(1,NSYMB), 10) ISTOR1(11,NSYMB) = K RETURN 210 CONTINUE WRITE (LIS2, FMT='('' Reduced ambiguity choices'', //, * 5X, ''H K L E1 Symbol'')') KTEST = KTEST + 1 MSYMB = 0 ISTO4 = ISTA4 - INCA4 ISTO5 = 0 DO 250 I=MCT,NCT,ICR 250 ITAB(I+6) = 0 DO 270 I=1,JSYMB K = ISTOR1(11,I) IF (ISTOR(I) .LE. ISMAX) THEN ITAB(K+2) = ISTOR1(2,I) ITAB(K+3) = ISTOR1(3,I) ITAB(K+4) = ISTOR1(4,I) IF (ITAB(K+2) .GE. 0) ITAB(K+4) = 0 ITAB(K+7) = ISTOR1(7,I) ISTOR1(11,I) = -1 GOTO 270 ENDIF MSYMB = MSYMB + 1 CALL KERNAI (ISTOR1(8,I), IHKL, 3) CALL IITAB4 (IHKL,K) ITAB(K+3) = 0 ITAB(K+4) = 1000 ISTO5 = ISTO5 + INCA5 ITAB(K+6) = (ISTO5) / 5 ITAB5(ISTO5+1) = 32767 ITAB5(ISTO5+4) = 0 ITAB5(ISTO5+5) = MSYMB E1 = FLOAT(ISTOR1(7,I)) / 100. WRITE (LIS2, 260) IHKL, E1, CHAR(MSYMB) 260 FORMAT (2X, 3I4, F7.2, 4X, A1) 270 CONTINUE K = 1 IF (NSYMB .LE. JSYMB) GOTO 350 DO 280 I=JSYMB+1,NSYMB K = ISTOR1(11,I) MSYMB = MSYMB + 1 CALL KERNAI (ISTOR1(8,I), IHKL, 3) CALL IITAB4 (IHKL, K) ITAB(K+3) = 0 ITAB(K+4) = 1000 ITAB(K+7) = -ITAB(K+7) ITAB(K+2) = ITAB(K+7) ISTO5 = ISTO5 + INCA5 ITAB(K+6) = ISTO5 / 5 ITAB5(ISTO5+1) = 32767 ITAB5(ISTO5+4) = 0 ITAB5(ISTO5+5) = MSYMB E1 = FLOAT(ISTOR1(7,I)) / 100. WRITE (LIS2, 260) IHKL, E1, CHAR(MSYMB) 280 IF (MSYMB .EQ. JSYMB) GOTO 290 290 K = 0 I = 0 310 I = I + 1 320 IF (ISTOR1(11,I) .GT. 0) GOTO 340 NSYMB = NSYMB - 1 DO 330 J=I,NSYMB 330 CALL KERNAI (ISTOR1(1,J+1), ISTOR1(1,J), 11) GOTO 320 340 IF (I .LE. JSYMB) GOTO 310 350 JSYMB = MSYMB DO 360 I=ISTO4+INCA4+1,ISIZ 360 ITAB(I) = 0 DO 370 I=ISTO5+INCA5+1,5*ISIZ5 370 ITAB5(I) = 0 WRITE (LIS1, 380) JSYMB WRITE (LIS2, 380) JSYMB 380 FORMAT (' Number of ambiguity symb. choices (reduced sec.', * 'set):', I5) IF (KTEST .EQ. 2) K = 1 RETURN END SUBROUTINE SYMREL (ISOL) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH EQUIVALENCE (IRD, IFILE(5)) EQUIVALENCE (IPR1, IFILE(6)) EQUIVALENCE (LIS1, IFILE(7)) EQUIVALENCE (LIS2, IFILE(8)) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ = 59876, ISIZ5 = 10000) INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5) LOGICAL REDUS COMMON / KLAD / ICODE(4,48), ISHIFT(48) COMMON / KLADC/ CHAR(12) CHARACTER CHAR *1 DIMENSION I2XI(2,10), IXI(10), ISOL(10,2), IXXI(40) EQUIVALENCE (IXXI(11), IXI(1)), (IXXI(21), I2XI(1,1)) DIMENSION KSY(10), KA(1023), KAA(1024), KAAA(1025) EQUIVALENCE (KA(1), KAA(2), KAAA(3)) DIMENSION KBB(110), LET1(4) DATA KBMAX1, KBMAX2 / 0, 0 / WRITE (LIS1, 200) WRITE (LIS2, 200) 200 FORMAT (/' Analysis of the symbolic phases A, B, ....') FAK = 2. / E000R CALL KERNZI (0, IXXI, 40) CALL KERNZI (0, KB10X, 15*25) CALL KERNZI (0, KB10XX, 15*25) IC123 = 0 KAAA(1) = JSYMB KMAX = 2**JSYMB KSY(1) = KMAX / 2 DO 210 I=2,JSYMB 210 KSY(I) = KSY(I-1) / 2 CALL KERNZI (0, KAA, KMAX) CALL KERNZI (0, KBB, 110) DO 370 K=MCT,NCT,ICR K51 = ITAB(K+6) IF (K51 .EQ. 0) GOTO 370 IF (IDC .GT. 1) GOTO 220 ITIP = ITAB(K+5) IF (ITIP.GE.0 .OR. ITAB(K+2).LT.0) GOTO 220 IF (ITIP.GT.-4 .OR. ITIP.LT.-8) GOTO 370 220 I51 = K51*INCA5 IF (ITAB(K+2).LT.0 .AND. ITAB(K+7).GT.0) GOTO 320 GOTO 240 230 K51 = IITAB5(I51,I51) 240 IF (IITAB5(I51,I52) .EQ. 0) GOTO 370 IF (ITAB5(I51+1) .NE. 32767) THEN IE1 = ALPS(I51) IF (IE1 .LE. 0) GOTO 230 IP1 = ITAB5(I51+2) ELSE IP1 = ITAB(K+3) IE1 = 32767 * FAK ENDIF ICOL1 = ITAB5(I51+5) CALL DECOL2 (ICOL1, LET1) IC1 = IABS(LET1(1)) IC3 = IABS(LET1(2)) IADR1 = KSY(IC1) IF (IC1 .EQ. IC3) GOTO 230 IF (IC3.NE.0 .AND. IDC.EQ.1) GOTO 230 IF (IC3 .GT. 0) IADR1 = IADR1 + KSY(IC3) IF (IC3 .NE. 0) GOTO 280 IP2 = ITAB(K+3) CALL PHDIF (IP2, IP1, IP12, IP2) I = MIN0(IP2,180-IP2) IF (I .LT. 5) GOTO 280 I = ISIGN(I,IP12) Q = ITAB(K+2) IF (Q .LT. 2.5) GOTO 280 I = FLOAT(I * IE1) * SQRT(Q) /100. IXXI(IC1) = IXXI(IC1) + ISIGN(1,ICOL1) * I GOTO 280 270 IF (IITAB5(I52,I52) .EQ. 0) GOTO 230 280 IE2 = ALPS(I52) IE2 = IALP(IE1,IE2) IF (IE2 .LE. 0) GOTO 270 IP2 = ITAB5(I52+2) ICOL2 = ITAB5(I52+5) CALL DECOL2 (ICOL2, LET1) IC2 = IABS(LET1(1)) IC4 = IABS(LET1(2)) IADR2 = KSY(IC2) IF (IC3.NE.0 .AND. IC4.NE.0) GOTO 270 IF (IC4 .GT. 0) IADR2 = IADR2 + KSY(IC4) IF (IC2 .EQ. IC4) GOTO 270 CALL PHDIF (IP1, IP2, IP12, IP2) IE2 = IE2 * (90-IP2) IF (ICOL1+ICOL2 .EQ. 0) GOTO 310 IADR = IADR1 + IADR2 IF (IC3.EQ.0 .AND. IC4.EQ.0) GOTO 300 IC123 = IC123 + 1 IF (IC4 .EQ. 0) GOTO 290 IF (IC2.EQ.IC1 .OR. IC4.EQ.IC1) IADR = IADR - 2*KSY(IC1) GOTO 300 290 IF (IC1.EQ.IC2 .OR. IC3.EQ.IC2) IADR = IADR - 2*KSY(IC2) 300 KA(IADR) = KA(IADR) + IE2 IF (IDC .EQ. 4) GOTO 270 IF (IC3.NE.0 .OR. IC4.NE.0) GOTO 270 IF (ICOL1*ICOL2 .LT. 0) IE2 = -IE2 I = 10*IC1 + IC2 KBB(I) = KBB(I) + IE2 GOTO 270 310 I2XI(2,IC1) = I2XI(2,IC1) + IABS(IE2) I2XI(1,IC1) = I2XI(1,IC1) + IE2 GOTO 270 320 IP1 = ITAB(K+3) GOTO 340 330 IF (IITAB5(I51,I51) .EQ. 0) GOTO 370 340 IP2 = ITAB5(I51+2) ICOL1 = ITAB5(I51+5) IC1 = IABS(ICOL1) EI2 = ALPS(I51) * 0.25 IF (EI2 .LT. 0.) GOTO 330 CALL PHDIF (IP1, IP2, IP12, IP2) IE2 = EI2 * (90.-FLOAT(IP2)) IF (IC1 .GT. 10) GOTO 350 IXI(IC1) = IXI(IC1) + IE2 I = MIN0(IP2,180-IP2) IF (I .LT. 5) GOTO 330 Q = ISIGN(I,IP12) IE2 = EI2 * Q IXXI(IC1) = IXXI(IC1) + ISIGN(1,ICOL1) * IE2 GOTO 330 350 CALL DECOL2 (ICOL1, LET1) IC1 = IABS(LET1(1)) IC2 = IABS(LET1(2)) IF (LET1(1) .EQ. LET1(2)) GOTO 360 IADR = KSY(IC1) + KSY(IC2) KA(IADR) = KA(IADR) + IE2 IF (IDC .EQ. 4) GOTO 330 IF (LET1(1)* LET1(2).GT.0) IE2 = -IE2 I = 10*IC1 + IC2 KBB(I) = KBB(I) + IE2 GOTO 330 360 I2XI(2,IC1) = I2XI(2,IC1) + IABS(IE2) I2XI(1,IC1) = I2XI(1,IC1) + IE2 GOTO 330 370 CONTINUE IF (IDC .EQ. 1) GOTO 400 WRITE (LIS2, 380) IC123 380 FORMAT (' ', I5, ' 3-letter-relations used') CALL SYMANA (0, IXI, KAAA, KSY, KB10X, KBMAX1) IF (IPSQ .EQ. 0) WRITE (LIS1, 390) IF (IPSQ .EQ. 0) WRITE (LIS2, 390) 390 FORMAT (' ***** Origin fixed *****') 400 IF (IDC .EQ. 4) GOTO 430 CALL KERNZI (0, KAA, KMAX) DO 410 I=1,JSYMB DO 410 J=1,JSYMB IF (I .EQ. J) GOTO 410 IC1 = 10*I + J IADR = KSY(I) + KSY(J) KA(IADR) = KA(IADR) + KBB(IC1) 410 CONTINUE CALL SYMANA (90, IXXI, KAAA, KSY, KB10XX, KBMAX2) IF (IDC.EQ.2 .OR. IPSQ.EQ.0) GOTO 425 WRITE (LIS2, 420) 420 FORMAT (' ***** Enantiomorph fixed *****') 425 IF (IDC .GT. 1) ESTAR1 = ESTART(1) - 0.1 430 IF (IPSQ .EQ. 0) GOTO 460 KBMAX1 = MAX0 (KBMAX1, 1) KBMAX2 = MAX0 (KBMAX2, 1) KBMAX = KBMAX1 * KBMAX2 KBMAX = MIN0 (KBMAX, 25) ILDUMP = 0 CALL DAFOMS (KBMAX, E1100, NR, 0., 0., 0, ILDUMP) IF (IDC .NE. 1) GOTO 450 DO 440 I=1,KBMAX2 440 CALL KERNAI (KB10XX(1,I), KB10X(1,I), 12) 450 CALL SOLCOM (KBMAX1, KBMAX2, KB10X, KB10XX, IDC, JSYMB) ILINK = 0 ELDAF = 0.0 IPHDAF = 0 CALL DAFOMS (0, ELDAF, IPHDAF, 0., 0., 0, ILINK) ILINK = MAX0 (ILINK, 1) ISOL(1,2) = ILINK DO 455 I=1,JSYMB 455 ISOL(I,1) = KB10X(I,ILINK) GOTO 600 460 DO 470 I=1,JSYMB IXI(I) = KB10X(I,1) 470 IXXI(I) = KB10XX(I,1) IF (IDC .EQ. 1) CALL KERNAI (IXXI, IXI, 10) IF (IDC .EQ. 4) CALL KERNAI (IXI, IXXI, 10) J = IDC - 1 DO 480 I=1,JSYMB IF (IXI(I).EQ.0 .AND. IXXI(I).EQ.270) IXI(I) = 360 480 ISOL(I,1) = (IXI(I) + J * IXXI(I)) / IDC 600 IF (IPSQ .EQ. 0) THEN WRITE (LIS1, 610) WRITE (LIS2, 610) 610 FORMAT (' Results of the symbolic addition method for', * ' the symbolic phases:') ELSE WRITE (LIS1, 620) WRITE (LIS2, 620) 620 FORMAT(' Results of the PSI0 and negative quartet FOMs', * ' for the symbolic phases:') ENDIF WRITE (LIS1, 630) (CHAR(I), ISOL(I,1), I=1,JSYMB) WRITE (LIS2, 630) (CHAR(I), ISOL(I,1), I=1,JSYMB) 630 FORMAT (3X, 10(A1,'=',I3,2X)) RETURN END SUBROUTINE SYMANA (KEY, KB, KAAA, KSY, KB10, KBMAXX) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH EQUIVALENCE (LIS1, IFILE(7)) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ = 59876, ISIZ5 = 10000) INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5) LOGICAL REDUS COMMON / KLAD / ICODE(4,48), ISHIFT(48) DIMENSION KB(10), KAAA(1025), KSY(10), K10(2,200) DIMENSION KB10(15,25) DATA KADR / 0 / CALL KERNZI (0, K10, 2*200) CALL KERNZI (0, KB10, 15*25) K5 = 1 IF (IPSQ .EQ. 1) K5 = 25 KBMAXX = 0 KX = 2**JSYMB + 1 DO 200 I=1,JSYMB IADR = KSY(I) + 2 200 KAAA(IADR) = KAAA(IADR) + KB(I)/10 K = 0 DO 210 I=2,KX 210 K = K + IABS(KAAA(I)) IF (K .GT. 0) GOTO 230 WRITE (LIS1, 220) 220 FORMAT ('0***** ERROR: no symbol relations; rerun PHASEX', /, * ' ***** with lower E-min values *********' /) GOTO 250 230 Q = 32001. / FLOAT(K) DO 240 I=2,KX 240 KAAA(I) = FLOAT(KAAA(I)) * Q CALL SYMAN (KAAA) 250 KMAX = -32100 DO 260 J=2,KX IF (KAAA(J) .LT. KMAX) GOTO 260 KMAX = KAAA(J) KADR = J 260 CONTINUE MAXR = KMAX * 100 / 32000 MAXADR = KADR - 2 KMIN = MIN0 (KMAX, 22400) * 7 / 10 KBMAX1 = 1 IF (IPSQ .EQ. 0) THEN K10(1,1) = KMAX K10(2,1) = KADR GOTO 305 ENDIF DO 300 I=2,KX IF (KAAA(I) .LE. KMIN) GOTO 300 DO 270 J=1,KBMAX1 IF (KAAA(I) .LE. K10(1,J)) GOTO 270 JJ = J GOTO 280 270 CONTINUE GOTO 300 280 DO 290 K=KBMAX1,JJ+1,-1 K10(1,K) = K10(1,K-1) 290 K10(2,K) = K10(2,K-1) K10(1,JJ) = KAAA(I) K10(2,JJ) = I KBMAX1 = KBMAX1 + 1 IF (KBMAX1 .GT. 200) KBMAX1 = 200 300 CONTINUE IF (KBMAX1 .NE. 200) KBMAX1 = KBMAX1 - 1 305 DO 360 J=1,KBMAX1 KADR = K10(2,J) MAXADR = KADR - 2 K = K10(1,J) MAXR = K * 100 / 3200 DO 320 I=1,JSYMB JJ = MAXADR / KSY(I) IF (JJ .EQ. 0) GOTO 310 KB(I) = KEY + 180 MAXADR = MAXADR - KSY(I) GOTO 320 310 KB(I) = KEY 320 CONTINUE JLINK = -J IF (IPSQ .EQ. 0) THEN JLINK = J ELSE CALL PHCOM1 (KB, JLINK) ENDIF IF (JLINK .EQ. J) THEN KBMAXX = KBMAXX + 1 CALL KERNAI (KB, KB10(1,KBMAXX), 10) KB10(11,KBMAXX) = J KB10(12,KBMAXX) = MAXR IF (KBMAXX .EQ. K5) RETURN ENDIF 360 CONTINUE RETURN END SUBROUTINE XXLINK (ISOL, ILINK) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 LOGICAL SWIPRI EQUIVALENCE (SWIPRI, SWITCH(10)) EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IBINDO, IFILE(13)) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ = 59876, ISIZ5 = 10000) INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5) LOGICAL REDUS PARAMETER (MAXBUF = 198) DIMENSION FITDOP(9), BUFDOP(MAXBUF) COMMON / SINCOS / IDEG(8), ISCT INTEGER*2 ISCT(450) DIMENSION IHKL(3), ISOL(10,2) COMMON / EPWCO / IP1, IPHS, IREST, IT, W1, WS, E1, E2, EL, EEE DIMENSION ITYP(4) CHARACTER LETT(4) *2, LITOUT *25 DATA LETT / '. ', 'S ', '* ', '*S' / DATA NLINPR / 0 / EEESUM = 0. ABSUM = 0. AB1SUM = 0. CALL KERNZI (0, ITYP, 4) NUMK = 0 MAXA4 = ISIZ ESTAR1 = ESTART(1) + 0.1 ISTO4 = MARKA4 IF (ILINK.EQ.0 .AND. MS.LT.700) MAXA4 = MAXA4 + (700-MS)*INCA4 ISW = 0 IF (ILINK .NE. 0) ISW = 1 EB = 100. * E000R ISL = 0 IF (SWIPRI) ISL = 1 SWIPRI = .FALSE. NITDOP = 9 CALL BINIFF (1, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP) IF (ISL .EQ. 1) SWIPRI = .TRUE. IF (.NOT.SWIPRI .OR. ILINK.NE.0) GOTO 230 WRITE (LIS2, 200) ESTAR1 200 FORMAT (' Results from DIRDIF.Special (end of PHASEX cycle 0),', * ' max. 300 refl. printed' / * '0* = accepted for basic set: W1.gt.0.16, EL.gt.', F4.2) IF (IDC .NE. 4) WRITE (LIS2, 210) 210 FORMAT (' S = special reflection (two possible phase values)') WRITE (LIS2, 220) 220 FORMAT ('0', 5(' H K L EL PL WS ') /) NLINPR = 0 CHOUT = '(5A25)' CALL LINPRX (LIS2, LITOUT, 25, 5) 230 IREFL = 0 DO 320 K=MCT,NCT,ICR LET = 1 CALL BINIFF (0, IBINDO, 'BINDOP', FITDOP, NITDOP, BUFDOP, KENDOP) IF (KENDOP .LT. 0) GOTO 330 IREFL = IREFL + 1 CALL KERF2I (FITDOP(1), IHKL(1), 3) E1 = FITDOP(4) IF (ILINK.GT.0 .AND. E1.LE.E1MIN) GOTO 320 E2 = FITDOP(5) IP1 = NINT(FITDOP(6)) W1 = FITDOP(7) IT = FITDOP(8) IREST = NINT(FITDOP(9)) NUMK = NUMK + 1 EL = E1 WS = W1 IF (IP1 .LE. 0) IP1 = IP1 + 360 IPHS = IP1 K51 = ITAB(K+6) KEY = 1 IF (K51 .EQ. 0) GOTO 280 LIBS = 0 KEY = 2 AEE = 0.0 BEE = 0.0 I51 = K51*INCA5 GOTO 245 240 I51 = K51*INCA5 + I51 245 IP = ITAB5(I51+2) EEE = ITAB5(I51+1) IF (EEE .LT. 32766.) GOTO 250 EEE = EB IP = ITAB(K+3) 250 ICOL = ITAB5(I51+5) I = IABS(ICOL) IF (I .GT. JSYMB) GOTO 260 KEY = 3 IP = IP + ISIGN(ISOL(I,1),ICOL) IP = MOD(IP,360) IF (IP .LE. 0) IP = IP + 360 AEE = AEE + EEE*ISCT(450-IP)/1000. BEE = BEE + EEE*ISCT(IP)/1000. EEESUM = EEESUM + EEE LIBS = LIBS + 1 260 K51 = ITAB5(I51+4) IF (K51 .NE. 0) GOTO 240 IF (LIBS .EQ. 0) GOTO 280 ITYP(4) = ITYP(4) + LIBS EEE = SQRT(AEE*AEE + BEE*BEE) ABSUM = ABSUM + EEE WW = W1 / 1000. IF (ITAB(K+2).LT.0 .AND. ITAB(K+7).GT.0) GOTO 270 IF (IT .NE. 1) GOTO 270 WW = WW*2. / IDC3**2 270 AEE = (AEE + EEE*ISCT(450-IP1)*WW)/10. BEE = (BEE + EEE*ISCT(IP1)*WW)/10. EEE = SQRT(AEE*AEE + BEE*BEE) IF (EEE .LT. 0.001) AEE = 0.1 PHS = ATAN2(BEE,AEE) * 57.2958 IF (PHS .LT. 0.) PHS = PHS + 360. IPHS = PHS + 0.5 WS = TANH(EEE/E000R)**2 CALL EPW AB1SUM = AB1SUM + EEE WS = AMAX1 (W1, WS) 280 IF (IT .EQ. 1) THEN E2AG(7) = E2AG(7) + EL*EL ELSE E2CG(7) = E2CG(7) + EL*EL ENDIF IF (ILINK .EQ. 0) THEN ITAB(K+2) = 100.*EL*WS + 0.5 ITAB(K+3) = IPHS ITAB(K+7) = 100.*EL + 0.5 ELSE CALL PHCOM2 (IPHS, ILINK) ENDIF ITYP(KEY) = ITYP(KEY) + 1 IF (EL.LT.ESTAR1 .OR. WS.LT.0.16) GOTO 290 IF (ISW .EQ. 1) GOTO 290 IF (ISTO4 .GT. MAXA4) GOTO 300 IF (ILINK .EQ. 0) CALL IITAB4 (IHKL, K) LET = LET + 2 290 ITAB1 = ITAB(K+1) IF (ILINK .EQ. 0) THEN ITAB(K+4) = 0 ITAB(K+5) = 0 ITAB(K+6) = 0 IF (ITAB(K+7) .LT. 0) ITAB(K+7) = -ITAB(K+7) ELSE CALL DAFOMS (ITAB1, EL, IPHS, WS, E1, IREFL, ILINK) ENDIF IF (.NOT.SWIPRI .OR. ILINK.GT.0) GOTO 320 IF (IT.NE.1 .AND. IDC.NE.4) LET = LET + 1 IF (SWIPRI .AND. NLINPR.LT.300) THEN NLINPR = NLINPR + 1 WRITE (LITOUT, FMT='(1X, 3I3, F5.2, I4, A2, F4.2)') * IHKL, EL, IPHS, LETT(LET), WS CALL LINPRX (0, LITOUT, 25, 5) ENDIF GOTO 320 300 WRITE (LIS1, 310) 310 FORMAT(' ******** WARNING: the basic set is not complete' ) ISW = 1 GOTO 290 320 CONTINUE 330 IF (SWIPRI .AND. ILINK.EQ.0) CALL LINPRX (-1, LITOUT, 25, 5) E2AG(7) = (E2AG(7) + E2ALE) / MAX0(1,NGN) E2CG(7) = (E2CG(7) + E2CLE) / MAX0(1,NSP) IF (EEESUM .LT. 0.0001) EEESUM = 1. C1EE = 10. * AB1SUM / EEESUM IF (ILINK .EQ. 0) GOTO 336 ISOL(1,2) = NINT(C1EE*1000.) I2000 = -2000 CALL PHCOM2 (IPHS, I2000) ILINK = I2000 RETURN 336 ITYP(3) = MAX0(1, ITYP(3)) WW = FLOAT(ITYP(4)) / ITYP(3) WRITE (LIS2, 340) (ITYP(I),I=1,3), WW 340 FORMAT ('0Number of refl. without symbolic phase: ', I11 / * ' Number of refl. without single-letter phase: ', I6 / * ' Number of refl. with N single-letter phases: ', I6 / * ' (N = 1 or more, average N = ', F5.2, ' )') MAXA4 = ISIZ - INCA4 MS = (ISTO4-MARKA4) / INCA4 WRITE (LIS2, 350) MS 350 FORMAT ('0Number of refl. in new basic set: ', I5 ) RETURN END SUBROUTINE SOLCOM (KBMAX1, KBMAX2, KB10X, KB10XX, IDC, JSYMB) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH EQUIVALENCE (IRD, IFILE(5)) EQUIVALENCE (IPR1, IFILE(6)) EQUIVALENCE (LIS2, IFILE(8)) PARAMETER (KBMAX = 25) DIMENSION KB10X(15,KBMAX), KB10XX(15,KBMAX), IXI(10), IXXI(10), * IX(10,2), KBXX(15,KBMAX) COMMON /SOLCPC/ KBTEMP(12,KBMAX*KBMAX), KBORD(12,KBMAX*KBMAX) WRITE (LIS2, FMT='(I6, '' solutions for the symmetrical'', * '' part '')') KBMAX1 CALL PHCOM2 (0, 0) ICONS2 = 0 CALL KERNZI (0, KBXX, 15*KBMAX) IF (IDC.EQ.2 .OR. IDC.EQ.3) GOTO 240 ICONS1 = KB10X (12,1) KBMAX1 = MAX0 (KBMAX1, KBMAX2) IACC = 0 DO 230 I=1,KBMAX1 DO 210 J=1,JSYMB 210 IX(J,1) = KB10X(J,I) ILINK = I CALL XXLINK (IX, ILINK) IF (ILINK .NE. I) GOTO 230 IACC = IACC + 1 CALL KERNAI (IX(1,1), KBXX(1,IACC), JSYMB) KBXX(11,IACC) = I CI = FLOAT(KB10X (12,I)) / FLOAT(ICONS1) KBXX(12,IACC) = NINT(CI * 1000.) KBXX(13,IACC) = IX(1,2) ICONS2 = MAX0 (ICONS2, IX(1,2)) 230 CONTINUE GOTO 330 240 WRITE (LIS2, FMT='(I6, '' solutions for the'', * '' antisymmetrical part '')') KBMAX2 WRITE (LIS2, FMT='(1X)') CALL KERNZI (0, KBTEMP, 12*KBMAX*KBMAX) CALL KERNZI (0, KBORD, 12*KBMAX*KBMAX) JDC = IDC - 1 JALL = 0 CONMAX = FLOAT (KB10X(12,1) + KB10XX(12,1)) / 1000. DO 252 I=1,KBMAX1 CALL KERNAI (KB10X(1,I), IXI(1), JSYMB) DO 251 J=1,KBMAX2 CALL KERNAI (KB10XX(1,J), IXXI(1), JSYMB) JALL = JALL + 1 KBTEMP(11,JALL) = JALL CONS = FLOAT (KB10X(12,I) + KB10XX(12,J)) / CONMAX KBTEMP(12,JALL) = NINT (CONS) DO 250 IN=1,JSYMB IXI1 = IXI(IN) IF (IXI1.EQ.0 .AND. IXXI(IN).EQ.270) IXI1 = 360 KBTEMP(IN,JALL) = (IXI1 + JDC*IXXI(IN)) / IDC 250 CONTINUE 251 CONTINUE 252 CONTINUE JJ = 1 DO 300 I=1,JALL IF (I .EQ. 1) GOTO 290 DO 260 J=1,I-1 IF (KBTEMP(12,I) .LT. KBORD(12,J)) GOTO 260 JJ = J GOTO 270 260 CONTINUE JJ = I GOTO 290 270 DO 280 K=I,JJ+1,-1 280 CALL KERNAI (KBORD(1,K-1), KBORD(1,K), 12) 290 CALL KERNAI (KBTEMP(1,I), KBORD(1,JJ), 12) 300 CONTINUE JSOL = 0 IACC = 0 DO 320 I=1,JALL CALL KERNAI (KBORD(1,I), IX(1,1), JSYMB) JSOL = JSOL + 1 ISOL = JSOL CALL XXLINK (IX, ISOL) IF (JSOL .EQ. ISOL) THEN IACC = IACC + 1 CALL KERNAI (IX(1,1), KBXX(1,IACC), JSYMB) KBXX(11,IACC) = KBORD(11,I) KBXX(12,IACC) = KBORD(12,I) ELSE GOTO 320 ENDIF KBXX(13,IACC) = IX(1,2) ICONS2 = MAX0 (ICONS2, IX(1,2)) IF (IACC .EQ. KBMAX) GOTO 330 320 CONTINUE 330 CALL KERNZI (0, KB10X, 15*KBMAX) DO 340 I=1,IACC CALL KERNAI (KBXX(1,I), KB10X(1,I), 15) CI = FLOAT(KB10X(13,I)) / FLOAT(ICONS2) 340 KB10X(13,I) = NINT(CI * 1000.) KBMAX1 = IACC IF (IDC.EQ.2 .OR. IDC.EQ.3) THEN WRITE (LIS2, FMT='(/I5, '' combined solutions'', * '' (symmetrical and antisymmetrical part)'')') KBMAX1 ELSE WRITE (LIS2, FMT='(1X)') ENDIF WRITE (LIS2, FMT='(5X, '' A B C D E F G'', * '' H I J No CONS1 CONS2'',/, * (I3, '') '', 13I5))') * (I1, (KB10X(I13,I1), I13=1,13), I1=1,KBMAX1) RETURN END SUBROUTINE PHCOM1 (KB, ICOM) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH, SWIPRI EQUIVALENCE (SWIPRI, SWITCH(10)) EQUIVALENCE (LIS2, IFILE(8)) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ = 59876, ISIZ5 = 10000) INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5) LOGICAL REDUS COMMON / KLADC / CHAR(12) CHARACTER CHAR *1 PARAMETER (IACC = 25) DIMENSION KB(10), KLET(10), PLET(10), KACC(11,IACC), LET(4) LOGICAL FIRST DATA FIRST / .FALSE. / DATA JACC, PMAX / 0, 0.0 / IF (FIRST) GOTO 250 FIRST = .TRUE. CALL KERNZI (0, KLET, JSYMB) NSYMB = 0 DO 200 K=MCT,NCT,ICR K5 = ITAB(K+6) IF (K5 .EQ. 0) GOTO 200 NSYMB = NSYMB + 1 I5 = K5 * INCA5 GOTO 185 180 I5 = K5*INCA5 + I5 185 ICOL = ITAB5(I5+5) I = IABS(ICOL) IF (I .LE. JSYMB) GOTO 186 CALL DECOL2 (I, LET) I = IABS(LET(1)) KLET(I) = KLET(I) + 1 I = IABS(LET(2)) KLET(I) = KLET(I) + 1 GOTO 190 186 KLET(I) = KLET(I) + 1 190 K5 = ITAB5(I5+4) IF (K5 .NE. 0) GOTO 180 200 CONTINUE NSUM = 0 DO 210 I=1,JSYMB 210 NSUM = NSUM + KLET(I) PSUM = 100. / FLOAT(NSUM) PMAX = 0. DO 220 I=1,JSYMB PLET(I) = FLOAT(KLET(I)) * PSUM 220 PMAX = MAX (PLET(I), PMAX) WRITE (LIS2, 230) NSYMB, (CHAR(I),I=1,JSYMB) 230 FORMAT (' Symbol frequency for ', I5, ' reflections: ', /, * 10X, 10(4X,A1)) WRITE (LIS2, FMT='(11X, 10I5)') (KLET(I),I=1,JSYMB) WRITE (LIS2,FMT='('' (in %) '', 1X, 10F5.1)') * (PLET(I), I=1,JSYMB) I = INT(PMAX) PMAX = FLOAT(I) IF (SWIPRI) * WRITE (LIS2, FMT='('' Two solutions are equal, if the symbol'' * ,'' changes'', /, '' between them are'', * '' less than '', F5.1, '' %'')') PMAX 250 IACOM = IABS(ICOM) IF (IACOM .EQ. 1) THEN CALL KERNZI (0, KACC, 11*IACC) JACC = 1 ICOM = IACOM CALL KERNAI (KB(1), KACC(1,JACC), JSYMB) KACC(11, JACC) = IACOM RETURN ENDIF DO 280 I=1,JACC PSUM = 0. DO 260 J=1,JSYMB IDIF = IABS(KACC(J,I) - KB(J)) DIF = FLOAT (IDIF) MULT = MIN (1.0, DIF) 260 PSUM = PSUM + MULT * PLET(J) IF (PSUM.LT.PMAX) RETURN 280 CONTINUE ICOM = IACOM JACC = JACC + 1 IF (JACC .GT. IACC) CALL KERROR ('Too many solutions',0, 'PHCOM1') CALL KERNAI (KB(1), KACC(1,JACC), JSYMB) KACC(11, JACC) = IACOM RETURN END SUBROUTINE PHCOM2 (IPHS, ILINK) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH, EXPAND EQUIVALENCE (EXPAND, SWITCH(23)) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) PARAMETER (NIPH = 1000, KBMAX = 25, * MAXD1 = 10, MAXD2 = 15) COMMON /PHC2PC/ * IPH(NIPH,KBMAX), IDIF(KBMAX), NDIF(KBMAX) DATA JSOL, NPH, JLINK, MAXDIF / 0, 0, 0, 0 / IF (ILINK .NE. 0) GOTO 200 MAXDIF = MAXD2 IF (ICENT.EQ.1 .OR. EXPAND) MAXDIF = MAXD1 CALL KERNZI (0, IPH, NIPH*KBMAX) CALL KERNZI (0, IDIF, KBMAX) NPH = 0 JSOL = 1 RETURN 200 IF (ILINK .EQ. -2000) GOTO 220 IF (JSOL .GT. KBMAX) * CALL KERROR (' To much solutions stored', 0, 'PHCOM2') NPH = NPH + 1 IF (NPH .GT. NIPH) THEN NPH = NIPH RETURN ENDIF JLINK = ILINK IPH(NPH,JSOL) = IPHS RETURN 220 IF (JLINK .EQ. 1) GOTO 270 DO 230 I=1,JSOL-1 DO 230 J=1,NPH IPH12 = IABS (IPH(J,I) - IPH(J,JSOL)) IF (IPH12 .GT. 180) IPH12 = 360 - IPH12 230 IDIF(I) = IDIF(I) + IPH12 ITEST = 0 DO 260 I=1,JSOL-1 MDIF = IDIF(I) / NPH IF (MDIF .LT. MAXDIF) ITEST = -1 IF (ITEST .EQ. -1) GOTO 265 260 CONTINUE GOTO 270 265 ILINK = -ILINK ELDAF = 0.0 IPHDAF = 0 CALL DAFOMS (0, ELDAF, IPHDAF, 0., 0., 0, -1) GOTO 280 270 NDIF(JSOL) = JLINK JSOL = JSOL + 1 ILINK = JLINK 280 NPH = 0 CALL KERNZI (0, IDIF, KBMAX) RETURN END SUBROUTINE GENERC COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH EQUIVALENCE (LIS1, IFILE(7)) EQUIVALENCE (LIS2, IFILE(8)) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ = 59876, ISIZ5 = 10000) INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5) LOGICAL REDUS COMMON / SINCOS / IDEG(8), ISCT COMMON / KLAD / ICODE(4,48), ISHIFT(48) INTEGER*2 ISCT(450) DIMENSION IHKL(3), IHKL3(3), LHIT(48) EQUIVALENCE (IHKL3(1), JJH1), (IHKL3(2), JJH2), (IHKL3(3),JJH3), * (MAXHKL(1), MAXH), (MAXHKL(2), MAXK), (MAXHKL(3),MAXL) DIMENSION LET1(4), LET1R(4), LET2(4) DATA K, NUMB, KTEST / 0, 0, 0/ MAXA5 = ISIZ5*INCA5 - INCA5 IF (ISTA4 .EQ. ISTA42) NUMB = 0 NUMBM = MAXA5 / INCA5 IF (NUMBM .GT. ISIZ5+INCA5) NUMBM = ISIZ5 - INCA5 ISTR1 = ISTA42 ISTR2 = MARKA4 + INCA4 MAX5 = MAXA5 - INCA5 ICENTR = 2*IICENT - 3 CALL KERNZI (0, LET1, 4) CALL KERNZI (0, LET1R, 4) CALL KERNZI (0, LET2, 4) DO 390 I41=ISTR1,ISTO4,INCA4 DO 200 I=1,3 200 IHKL(I) = ITAB(I41+I) NEQ = 2 CALL SYMEQ (IHKL, NEQ) IR1 = ITAB(I41+4) + MCT IE1 = ITAB(IR1+2) IPH1 = ITAB(IR1+3) DO 210 I=1,NEQ IS2 = ISHIFT(I) ISHIFT(I) = IPH1 + IDEG(IS2) ISHIFT(I+NEQ) = -ISHIFT(I) 210 CONTINUE K51S = ITAB(IR1+6)*INCA5 + INCA5 ICOL1 = ITAB5(K51S) ICOL1R = ICENTR * ICOL1 CALL DECOL2 (ICOL1, LET1) LET1R(1) = ICENTR * LET1(1) LET1R(2) = ICENTR * LET1(2) ISTOP = I41 - INCA4 NEQ2 = NEQ * 2 DO 380 I42=ISTR2,ISTOP,INCA4 JH1 = ITAB(I42+1) JH2 = ITAB(I42+2) JH3 = ITAB(I42+3) IR2 = ITAB(I42+4) + MCT IF (I42 .LT. ISTA4) GOTO 220 K52S = ITAB(IR2+6)*INCA5 + INCA5 ICOL2 = ITAB5(K52S) CALL DECOL2 (ICOL2, LET2) CALL COLAD (LET1, LET2, ICOL, IICENT) CALL COLAD (LET1R, LET2, ICOLR, IICENT) IF (ICOL.EQ.0 .AND. ICOLR.EQ.0) GOTO 380 GOTO 230 220 ICOL = ICOL1 ICOLR = ICOL1R 230 IPH2 = ITAB(IR2+3) IWEE = IE1 * ITAB(IR2+2) J = ITAB(IR2+1) NHIT = 0 NQQ1 = 1 NQQ2 = NEQ IF (ICOL .EQ. 0) GOTO 370 240 DO 360 I11 = NQQ1,NQQ2 IF (MCTLAT .GT. 1) GOTO 250 I = ICODE(4,I11) KTEST = I + J K = IABS(KTEST) IF (K .EQ. 0) GOTO 360 IF (K .GT. MCT) GOTO 360 IF (ITAB(K) .EQ. 0) GOTO 360 250 JJH1 = ICODE(1,I11) + JH1 IF (IABS(JJH1) .GT. MAXH) GOTO 360 JJH2 = ICODE(2,I11) + JH2 IF (IABS(JJH2) .GT. MAXK) GOTO 360 JJH3 = ICODE(3,I11) + JH3 IF (IABS(JJH3) .GT. MAXL) GOTO 360 IF (MCTLAT .EQ. 1) GOTO 260 KTEST = INPACK(IHKL3) K = IABS(KTEST) IF (K .EQ. 0) GOTO 360 IF (ITAB(K) .EQ. 0) GOTO 360 260 K = ITAB(K) LTEST = IABS(K) L = LTEST / 4096 IR3 = (LTEST-L*4096-1)*ICR + MCT IF (IR3.EQ.IR2 .OR. IR3.EQ.IR1) GOTO 360 IF (NHIT .EQ. 0) GOTO 280 DO 270 IHIT=1,NHIT IF (IR3 .EQ. LHIT(IHIT)) GOTO 360 270 CONTINUE 280 NHIT = NHIT + 1 LHIT(NHIT) = IR3 L = L + 1 ISS = ISIGN(1,K) * ISIGN(1,KTEST) IPH3 = ISS * (ISHIFT(I11)+IPH2)-IDEG(L) IF (ISS .EQ. 1) GOTO 290 ICOL3 = ICENTR * ICOL GOTO 300 290 ICOL3 = ICOL 300 IPH3 = MOD(IPH3,360) IF (IPH3 .LE. 0) IPH3 = IPH3 + 360 K53 = ITAB(IR3+6) IF (K53 .NE. 0) GOTO 310 IF (NUMB+JSYMB .GE. NUMBM) GOTO 400 ISTO5 = ISTO5 + INCA5 ITAB(IR3+6) = ISTO5 / INCA5 GOTO 340 310 I53 = K53*INCA5 IF (ITAB5(I53+5) .NE. ICOL3) GOTO 330 IF (ITAB5(I53+1) .EQ. 32767) GOTO 360 GOTO 350 320 I53 = K53*INCA5 + I53 IF (ITAB5(I53+5) .EQ. ICOL3) GOTO 350 330 K53 = ITAB5(I53+4) IF (K53 .NE. 0) GOTO 320 IF (ISTO5.GT.MAX5 .OR. (NUMB+JSYMB).GE.NUMBM) GOTO 400 ISTO5 = ISTO5 + INCA5 ITAB5(I53+4) = (ISTO5 - I53) / 5 340 ITAB5(ISTO5+1) = IWEE * ISCT(450-IPH3)/1000000 ITAB5(ISTO5+2) = IWEE * ISCT(IPH3)/1000000 ITAB5(ISTO5+3) = IWEE / 1000 ITAB5(ISTO5+4) = 0 ITAB5(ISTO5+5) = ICOL3 NUMB = NUMB + 1 GOTO 360 350 ITAB5(I53+1) = ITAB5(I53+1) + IWEE*ISCT(450-IPH3)/1000000 ITAB5(I53+2) = ITAB5(I53+2) + IWEE*ISCT(IPH3)/1000000 ITAB5(I53+3) = ITAB5(I53+3) + IWEE/1000 360 CONTINUE 370 IF (NQQ2.EQ.NEQ2 .OR. ICOLR.EQ.0) GOTO 380 ICOL = ICOLR NQQ1 = NEQ+1 NQQ2 = NEQ2 GOTO 240 380 CONTINUE 390 CONTINUE GOTO 420 400 WRITE (LIS2, 410) NUMB+JSYMB, NUMBM 410 FORMAT ('0There is not enough storage (subr. GENERC):', /, * ' Number of relations (', I5, ') .GE. max. number of', * ' relations (', I5, ')') WRITE (LIS2, FMT='('' Generation is stopped at reflection : '', * 3I4, '' (='', I4, ''. refl. in secondary set)'')') * (ITAB(I41+I3), I3=1,3), (I41-ISTR1)/4 420 WRITE (LIS1, 430) NUMB+JSYMB WRITE (LIS2, 430) NUMB+JSYMB 430 FORMAT (' Total number of phases with symbols:', I21) RETURN END SUBROUTINE DECOL2 (ICOL, LET) DIMENSION LET(4) IF (IABS(ICOL) .LE. 10) GOTO 100 LET(1) = (ICOL+220) / 21 - 10 LET(2) = ICOL - LET(1)*21 RETURN 100 LET(2) = 0 LET(1) = ICOL RETURN END SUBROUTINE COLAD (LET1, LET2, ICOL, ICENT) DIMENSION LET1(4), LET2(4) DATA N / 2 / ICOL = 0 I1 = 1 I2 = 1 I = 0 200 IF (IABS(LET1(I1)) - IABS(LET2(I2))) 210, 240, 230 210 IF (I .EQ. N) GOTO 250 ICOL = ICOL * 21 + LET2(I2) I2 = I2 + 1 220 I = I + 1 GOTO 200 230 IF (I .EQ. N) GOTO 250 ICOL = ICOL * 21 + LET1(I1) I1 = I1 + 1 GOTO 220 240 IF (LET1(I1) .EQ. 0) RETURN IF (ICENT.EQ.1 .AND. LET1(I1).EQ.LET2(I2)) GOTO 210 I1 = I1 + 1 I2 = I2 + 1 GOTO 200 250 ICOL = 0 RETURN END SUBROUTINE REAR COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ = 59876, ISIZ5 = 10000) INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5) LOGICAL REDUS FAK = 1. DO 260 K=MCT,NCT,ICR IF (ITAB(K+6) .EQ. 0) GOTO 260 E1 = ITAB(K+7) / 100. IF (E1 .LT. 0.0) E1 = -E1 J = ITAB(K+6)*INCA5 IMAX = J II = J IF (ITAB5(J+1) .NE. 32767) GOTO 200 AX = 32767. GOTO 230 200 AX = 0.0 210 AEE = ITAB5(II+1) BEE = ITAB5(II+2) EEE = SQRT(AEE*AEE+BEE*BEE) * E1 IF (EEE .LT. 0.001) AEE = 1.0 PH3 = ATAN2(BEE,AEE) IEE = EEE + 1.0 IWEE = ITAB5(II+3)*E1 + 0.5 ITAB5(II+1) = MIN0(IEE,IWEE) ITAB5(II+3) = MAX0(1,IWEE) EEE = ALPS(II) IF (EEE .LE. AX) GOTO 220 AX = EEE IMAX = II 220 PH3 = PH3 * 57.2958 IF (PH3 .LT. 0.0) PH3 = PH3 + 360. ITAB5(II+2) = PH3 + 0.5 230 CONTINUE IJ = II II = ITAB5(II+4) IF (II .EQ. 0) GOTO 240 II = II*INCA5 + IJ GOTO 210 240 IF (J .EQ. IMAX) GOTO 260 DO 250 I=1,5 IF (I .EQ. 4) GOTO 250 II = IMAX + I JJ = J + I MAX = ITAB5(II) ITAB5(II) = ITAB5(JJ) ITAB5(JJ) = MAX 250 CONTINUE 260 CONTINUE RETURN END FUNCTION ALPS (I51) COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ5 = 10000) INTEGER *2 ITAB5(5*ISIZ5) LOGICAL REDUS A = ITAB5(I51+1) B = ITAB5(I51+3) ALPS = (2.*A/B - 1.) * A * FAK RETURN END SUBROUTINE TACCEP (NLET, NTEMP) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH, SWIPRI EQUIVALENCE (SWIPRI, SWITCH(10)) COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 EQUIVALENCE (LIS1, IFILE(7)) EQUIVALENCE (LIS2, IFILE(8)) COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ = 59876, ISIZ5 = 10000) INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5) LOGICAL REDUS COMMON / KLAD / ICODE(4,48), ISHIFT(48) COMMON / KLADC / CHAR(12) CHARACTER CHAR *1 DIMENSION IHKL(3), NLET(10), ISYMB(4), LET1(4), KARR(100) CHARACTER LITOUT *32 DATA AEMIN / 0.0 / QEETO = QEET 111 CONTINUE CALL KERNZI (0, LET1, 4) MAXX = (MAXA4-ISTO4) / INCA4 IF (MAXT .GT. MAXX) MAXT = MAXX ISTA42 = ISTO4 + INCA4 ISW = 1 AMIN = 0.1 AMAX = 5.0 200 CALL VALDIS (-1, AMIN, AMAX, KARR, 100, NTEMP) FAK = 0.2 / E000R FAK1 = FAK / 2. FAKA = FAK / 100. IQEET = 100. * QEET AMINE = 1000. AMAXE = 0. 210 NTEMP = 0 IF (ISW .NE. 3) GOTO 240 WRITE (LIS2, 220) AEMIN 220 FORMAT (' For temporarily accepted reflections:', * ' minimum Alpha * E1 = ', F6.3) IF (.NOT. SWIPRI) GOTO 240 WRITE (LIS2, 230) 230 FORMAT ('0Temporarily accepted reflections = secondary set:' / * ' ', 4(' H K L E1 symb.phase W ') /) CHOUT = '(4A32)' CALL LINPRX (LIS2, LITOUT, 32, 4) 240 DO 300 K=MCT,NCT,ICR IEW = ITAB(K+2) IF (IEW .LT. 0) GOTO 300 K5 = ITAB(K+6) IF (K5 .EQ. 0) GOTO 300 I5 = K5*INCA5 IEEE = ITAB5(I5+1) IE = ITAB(K+7) IF (IDC .GT. 1) GOTO 250 ITIP = ITAB(K+5) IF (ITIP .GT. -1) GOTO 250 IF (ITIP.GT.-5 .OR. ITIP.LT.-7) GOTO 300 250 IF (IE .GT. 399) GOTO 300 I = IQEET * ITAB5(I5+3) IF (I .GT. 100*IEEE) GOTO 300 AE = IE * IEEE AE = AE * FAKA IF (ISW .GE. 2) GOTO 260 CALL VALDIS (0, AE, 0., KARR, 100, NTEMP) AMINE = AMIN1 (AMINE, AE) AMAXE = AMAX1 (AMAXE, AE) GOTO 300 260 IF (AE .LT. AEMIN) GOTO 300 ICOL = ITAB5(I5+5) CALL DECOL2 (ICOL, LET1) LL1 = IABS(LET1(1)) LL2 = IABS(LET1(2)) IF (ISW .EQ. 3) GOTO 280 NTEMP = NTEMP + 1 NLET(LL1) = NLET(LL1) + 1 IF (LL2 .NE. 0) NLET(LL2) = NLET(LL2) + 1 GOTO 300 280 IF (NLET(LL1) .LT. 1) GOTO 300 IF (LL2 .EQ. 0) GOTO 290 IF (NLET(LL2) .LT. 1) GOTO 300 290 IF (NTEMP .GE. MAXT) GOTO 350 NTEMP = NTEMP + 1 NLET(LL1) = NLET(LL1) + 1 IF (LL2 .GT. 0) NLET(LL2) = NLET(LL2) + 1 ICHKL = ITAB(K+1) CALL XUNPAK (ICHKL, IHKL) CALL IITAB4 (IHKL, K) W = TANH(IEEE*FAK1)**2 FAKWS = FAKWS + W E1 = IE / 100. IE = -IE IF (REDUS) GOTO 295 ITAB(K+7) = IE ITAB(K+2) = IE*W - 0.5 ITAB(K+4) = 1000. * W ITAB(K+3) = ITAB5(I5+2) 295 IF (.NOT. SWIPRI) GOTO 300 CALL KERNZI (12, ISYMB(1), 4) IF (LET1(1) .LT. 0) ISYMB(1) = 11 ISYMB(2) = LL1 IF (LET1(2) .LT. 0) ISYMB(3) = 11 IF (LL2 .GT. 0) ISYMB(4) = LL2 IP = ITAB5(I5+2) WRITE (LITOUT, FMT='(1X,3I3,F5.2,1X,4A1,'' +'',I3,''.'',F5.2,1X)') * IHKL, E1, CHAR(ISYMB(1)), CHAR(ISYMB(2)), * CHAR(ISYMB(3)), CHAR(ISYMB(4)), IP, W CALL LINPRX (0, LITOUT, 32, 4) 300 CONTINUE GOTO (310, 320, 350), ISW 310 I = MAXT + 10 IF (KARR(1).GT.I .OR. KARR(100).GT.I) THEN AMIN = AMINE - 0.1 AMAX = AMAXE + 0.1 GOTO 200 ENDIF ISW = 2 CALL VALDIS (I, AEMIN, 0., KARR, 100, NTEMP) GOTO 210 320 ISW = 3 NLETM = 4 IF (MS .LE. 20) NLETM = 1 DO 340 I=1,10 IF (NLET(I) .GE. NLETM) GOTO 330 IF (NLET(I) .EQ. 0) GOTO 340 NLET(I) = -1 GOTO 340 330 NLET(I) = 1 340 CONTINUE ITEST = 0 DO 345 I=1,10 345 IF (NLET(I) .LT. 1) ITEST = 1 IF (ITEST .EQ. 0) REDUS = .FALSE. GOTO 210 350 IF (SWIPRI) CALL LINPRX (-1, LITOUT, 32, 4) WRITE (LIS1, 360) NTEMP WRITE (LIS2, 360) NTEMP 360 FORMAT (' Number of temporarily accepted refl. (secondary set):', * I4) IF (NTEMP .LE. 0) THEN CHOUT = ' No temp. acc. refl. found, decrease QEET and try.' CALL SHOUT2 QEET = 0.5 * QEET -0.01 IF (QEET .GT. 0.4 * QEETO) GOTO 111 CHOUT = 'Again no temp. acc. refl. found ... scaling error???' CALL SHOUT2 CHOUT = 'Continuation may be unreliable..... but we will try!' CALL SHOUT2 ENDIF FAKWS = AMAX1 (2., 0.3 * NTEMP / FAKWS) DO 380 I=1,10 IF (NLET(I) .LT. 0) NLET(I) = 1 380 CONTINUE WRITE (LIS2, 390) (CHAR(I),I=1,JSYMB) 390 FORMAT (' Symbol frequency in basic set', /, 1X, 10(3X, A1)) WRITE (LIS2, FMT='(1X, 10I4)') (NLET(I), I=1,JSYMB) RETURN END SUBROUTINE REAR2 COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ = 59876, ISIZ5 = 10000) INTEGER *2 ITAB(ISIZ), ITAB5(5*ISIZ5) LOGICAL REDUS COMMON / SINCOS / IDEG(8), ISCT INTEGER*2 ISCT(450) DO 220 K=MCT,NCT,ICR K5 = ITAB(K+6) IF (K5 .EQ. 0) GOTO 220 E1 = ITAB(K+7) * 10. IF (E1 .LT. 0.0) E1 = -E1 KK5 = K5 * INCA5 IF (ITAB5(KK5+1) .EQ. 32767) GOTO 210 200 EEE = ITAB5(KK5+1) / E1 IPH = ITAB5(KK5+2) IF (IPH .LE. 0) IPH = IPH + 360 ITAB5(KK5+1) = EEE * ISCT(450-IPH) ITAB5(KK5+2) = EEE * ISCT(IPH) ITAB5(KK5+3) = ITAB5(KK5+3) / E1*1000. 210 K5 = ITAB5(KK5+4) IF (K5 .EQ. 0) GOTO 220 KK5 = K5*INCA5 + KK5 GOTO 200 220 CONTINUE RETURN END SUBROUTINE SYMAN (A) INTEGER A(1025) NSY = A(1) M = 2**NSY KM = M * 2 DO 100 I = 1, NSY KM = KM / 2 LM = KM / 2 DO 100 K=1,M,KM N = K + LM DO 100 L=1,LM IA = A(K+L) A(K+L) = IA + A(N+L) 100 A(N+L) = IA - A(N+L) RETURN END INTEGER FUNCTION IITAB5 (I51, I52) COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ5 = 10000) INTEGER *2 ITAB5(5*ISIZ5) LOGICAL REDUS I52 = ITAB5(I51+4)*INCA5 + I51 IITAB5 = ITAB5(I51+4) RETURN END FUNCTION IALP (IA, IB) DIMENSION IK(50) DATA IK / 10149, 9510, 8887, 8286, 7711, 7161, 6641, 6151, 5693, * 5266, 4871, 4505, 4169, 3863, 3581, 3324, 3090, 2878, * 2685, 2510, 2350, 2206, 2075, 1956, 1848, 1749, 1659, * 1577, 1502, 1433, 1388, 1332, 1296, 1243, 1190, 1139, * 1089, 1056, 1008, 961, 941, 920, 899, 879, 866, * 853, 840, 827, 814, 801 / IC = MAX0(IA,IB) IF (IC .LT. 51) GOTO 200 IALP = MIN0 (IA, IB, (IA+IB)/4) GOTO 240 200 M = MIN0 (IA, IB) IF (M .LT. 3) GOTO 220 K = IK(IA) + IK(IB) IF (K .GT. 10149) GOTO 220 N = M - 1 DO 210 I=2,N II = M - I IF (IK(II) .GT. K) GOTO 230 210 CONTINUE 220 IALP = 0 GOTO 240 230 IALP = II 240 RETURN END SUBROUTINE DAFOMS (INCODE, EL, IPH, WS, E1, IREFL, ILINK) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH, SWIPRI, EXPAND EQUIVALENCE (SWIPRI, SWITCH(10)), (EXPAND, SWITCH(23)) COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 EQUIVALENCE (LIS1, IFILE( 7)) EQUIVALENCE (LIS2, IFILE( 8)) EQUIVALENCE (IE100, IFILE(10)) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) COMMON / KLAD / ICODE(4,48), ISHIFT(48) COMMON / SINCOS / IDEG(8), ISCT INTEGER*2 ISCT(450) PARAMETER (MAXNR = 1000, MAXADR = 4000, IBEMAX = 25) COMMON /DAFOPC/ * ITAB25(4,MAXNR,IBEMAX), IWEAK(4,100), DIF(4,IBEMAX), * WEAKR(4,100,IBEMAX), ITAD(-1:MAXADR), QEST(3,IBEMAX), * KARR(100), IH(3), IK(3), IL(3), IHPK(3), * IHKL(3), IHPL(3), IKPL(3), IHML(3), ICODEH(3,48), * P1SOL(IBEMAX), IP1SOL(IBEMAX), P2SOL(IBEMAX), * IP2SOL(IBEMAX), Q1SOL(IBEMAX), IQ1SOL(IBEMAX), * Q2SOL(IBEMAX), IQ2SOL(IBEMAX), IPQSOL(IBEMAX) LOGICAL FIRST, LAUEP, PSIZ DATA FIRST, LAUEP, PSIZ / .FALSE., .FALSE., .TRUE. / DATA MINTRI / 10 / DATA IBEST, IKEND, IREF, IRED, IOLD, NNSYMM / 0, 0, 0, 0, 0, 0/ DATA J12, IICENT, NREFL, E1100, KBMAX / 0, 0, 0, 0.0, 0/ IF (FIRST) GOTO 210 FIRST = .TRUE. KBMAX = MIN0 (INCODE, IBEMAX) IF (ILAUE.GT.3 .AND. .NOT.EXPAND) LAUEP = .TRUE. E1100 = EL NREFL = IPH IF (NREFL.GT.MAXADR) CALL KERROR * ('Reduce number of reflections to MAXADR (= 4000)', 0,'DAFOMS') NNSYMM = NSYMM IICENT = ICENT IF (EXPAND) THEN NNSYMM = 1 IICENT = 1 ENDIF IBEST = 1 IOLD = 1 IKEND = 0 ITAD(0) = 0 ITAD(-1) = 0 IRED = 0 CALL KERNZI (0, ITAB25, 4*MAXNR*IBEMAX) CALL KERNZA (0., WEAKR, 400*IBEMAX) CALL KERNZA (0., QEST, 3*IBEMAX) CALL KERNZI (0, ITAD, MAXADR) CALL KERNZI (0, IWEAK, 400) CALL KERNZI (0, IHKL, 3) RETURN 210 IF (ILINK) 330, 340, 220 220 IF (IOLD .NE. ILINK) GOTO 270 IF (IKEND .GE. MAXNR) RETURN IF (IKEND .GE. NREFL) THEN CHOUT = ' too many symbols. Scaling error ?? Try to go on' CALL SHOUT2 RETURN ENDIF IKEND = IKEND + 1 ITAB25(1,IKEND,IBEST) = INCODE ITAB25(2,IKEND,IBEST) = NINT(EL*1000.) ITAB25(4,IKEND,IBEST) = NINT(WS*1000.) ITAB25(3,IKEND,IBEST) = IPH IF (IBEST .GT. 1) RETURN ITAB25(3,IKEND,1) = IPH + 370*IREFL IF (E1.LE.E1100 .OR. IRED.EQ.100) RETURN IRED = IRED + 1 ITAB25(2,IKEND,1) = -ITAB25(2,IKEND,1) RETURN 270 IF (IBEST .GT. 1) GOTO 320 DO 310 I=1,IKEND IADR = ITAB25(3,I,1) / 370 ITAB25(3,I,1) = ITAB25(3,I,1) - IADR*370 ITAD(IADR) = I 310 CONTINUE IREF = IKEND 320 IBEST = IBEST + 1 IF (IBEST .LE. KBMAX) THEN IKEND = 0 IOLD = ILINK GOTO 210 ELSE CALL KERNER (-4, 'DAFOMS') ENDIF 330 IOLD = IOLD + 1 IKEND = 0 RETURN 340 IF (IKEND .EQ. 0) IBEST = IBEST - 1 WRITE (LIS1, FMT='('' Psi0 FOM and negative quartet FOM:'')') WRITE (LIS2, FMT='(/'' Psi0 FOM and negative quartet FOM:'')') WRITE (LIS2, 345) IREF, IRED 345 FORMAT (' Number of reflections stored in table: ', I4, /, * ' Number of reflections in reduced table: ', I4, * ' (= strongest refl.)') IF (IBEST .EQ. 1) THEN ILINK = 1 RETURN ENDIF READ (IE100, FMT='(A80)') CHIN IF (SWIPRI) WRITE (LIS2, FMT='(A80)') CHIN READ (CHIN, FMT='(5X, I3)') N100 IF (N100 .LE. 10) CALL KERROR * (' There are not enough weak reflections (< 10)', 0, 'DAFOMS') N100 = MIN0 (N100, 100) DO 380 I=1,N100 READ (IE100, FMT='(3I4)') (IWEAK(J,I), J=1,3) CALL KERNAI (IWEAK(1,I), IHKL, 3) 380 IWEAK(4,I) = IGROUP(IHKL) - 1 IF (.NOT. SWIPRI) GOTO 395 WRITE (LIS2, FMT='('' (G = parity group)'')') WRITE (LIS2, 385) ((IWEAK(I4,I), I4=1,4), I=1,N100) 385 FORMAT (' H K L G', / (10(1X,3I3,I2))) WRITE (LIS2, 390) IREF, IRED, E1100 390 FORMAT (' The table of ', I4, ' reflections is reduced to', * I4, ' strongest reflections (min E1 = ', F5.3, ')') WRITE (LIS2, FMT='('' The '', I4, '' strongest reflections:'', * /, '' No H K L'')') IREF DO 394 I=0,IREF-1,12 DO 391 J=1,12 IF (I+J .GT. IREF) GOTO 392 J12 = J CALL XUNPAK (ITAB25(1,I+J,1), IHKL) 391 CALL KERNAI (IHKL, ICODEH(1,J), 3) 392 WRITE (LIS2, 393) I+1, ((ICODEH(I3,I12), I3=1,3), I12=1,J12) 393 FORMAT (I5, 12(1X,3I3)) 394 CONTINUE 395 CALL KERNZI (0, ICODEH, 3*48) CALL KETIME (LIS2) NREL = 0 CALL KERNZI (0, KARR, 100) DO 431 IJ=1,IREF IF (ITAB25(2,IJ,1) .GT. 0) GOTO 431 ITAB25(2,IJ,1) = IABS (ITAB25(2,IJ,1)) IF (NREL .GT. 5000) GOTO 435 CALL XUNPAK (ITAB25(1,IJ,1), IK) NEQ = 2 CALL SYMEQ (IK, NEQ) IF (NEQ .NE. NNSYMM) GOTO 431 NEQ2 = NEQ * 2 DO 400 INEQ=1,NEQ ISHIFT(INEQ) = IDEG(ISHIFT(INEQ)) 400 ISHIFT(INEQ+NEQ) = -ISHIFT(INEQ) DO 430 I=1,N100 CALL KERNAI (IWEAK(1,I), IH, 3) IHIT = 0 CALL KERNZA (0., DIF, 4*IBEMAX) DO 410 II=1,NEQ2 ISK = 1 IF (II .GT. NEQ) ISK = -1 CALL KERNAI (ICODE(1,II), IK, 3) CALL GENERP (IH, IK, IADR, ISHMK) IADR = ITAD(IADR) IF (IADR .EQ. 0) GOTO 415 ISS = ISIGN(1,ISHMK) ISHMK = IDEG(IABS(ISHMK)) IHIT = IHIT + 1 DO 405 J=1,IBEST IPK = ISK * (ITAB25(3,IJ,J) + ISHIFT(II)) IPHMK = ISS * (ITAB25(3,IADR,J) + ISHMK) IPHK = IPHMK + IPK IPHK = MOD(IPHK, 360) IF (IPHK .LE. 0) IPHK = 360 + IPHK EH = FLOAT (ITAB25(2,IJ,J)) / 1000. EK = FLOAT (ITAB25(2,IADR,J)) / 1000. EHEK = EH * EK ICOSHK = ISCT(450-IPHK) COSHK = FLOAT(ICOSHK) / 1000. EHEKC = EHEK * COSHK DIF(1,J) = DIF(1,J) + EHEKC IF (IICENT .EQ. 1) THEN ISINHK = ISCT(IPHK) SINHK = FLOAT(ISINHK) / 1000. EHEKS = EHEK * SINHK EHEK2 = EHEKC**2 + EHEKS**2 DIF(2,J) = DIF(2,J) + EHEKS DIF(3,J) = DIF(3,J) + SQRT(EHEK2) DIF(4,J) = DIF(4,J) + EHEK2 ELSE DIF(3,J) = DIF(3,J) + ABS(EHEKC) DIF(4,J) = DIF(4,J) + EHEKC**2 ENDIF 405 CONTINUE 410 CONTINUE 415 CONTINUE IF (IHIT .GT. 0) THEN KARR(I) = KARR(I) + IHIT NREL = NREL + IHIT DO 420 J=1,IBEST WEAKR(1,I,J) = WEAKR(1,I,J) + DIF(1,J) WEAKR(2,I,J) = WEAKR(2,I,J) + DIF(2,J) WEAKR(3,I,J) = WEAKR(3,I,J) + DIF(3,J) 420 WEAKR(4,I,J) = WEAKR(4,I,J) + SQRT(DIF(4,J)) ENDIF 430 CONTINUE 431 CONTINUE GOTO 437 435 WRITE (LIS2, FMT='('' PSI0 generation is stopped at refl. No.'', * I3, 2X, 3I4)') IJ, IK DO 436 I=IJ,IREF 436 ITAB25(2,I,1) = IABS (ITAB25(2,I,1)) 437 WRITE (LIS1, 440) N100, NREL WRITE (LIS2, 440) N100, NREL 440 FORMAT (' The ', I3, ' weakest reflections take part in', I5, * ' triplet relationships.') IHIT = 0 JREFL = 0 CALL KERNZA (0.0001, DIF, 4*IBEMAX) DO 460 I=1,N100 IF (KARR(I) .LT. MINTRI) GOTO 460 JREFL = JREFL + 1 IHIT = IHIT + KARR(I) DO 450 J=1,IBEST WEAKR(1,I,J) = SQRT(WEAKR(1,I,J)**2 + WEAKR(2,I,J)**2) DIF(1,J) = DIF(1,J) + WEAKR(1,I,J) DIF(2,J) = DIF(2,J) + WEAKR(3,I,J) DIF(3,J) = DIF(3,J) + WEAKR(4,I,J) 450 CONTINUE 460 CONTINUE IF (IHIT .EQ. 0) THEN WRITE (LIS2, 470) 470 FORMAT (/' Sory, PSIzero FOM not possible, there are not ', * 'enough hits (10) per weak refl.') NREL = 0 PSIZ = .FALSE. GOTO 530 ENDIF HIT = FLOAT(IHIT) / FLOAT(JREFL) WRITE (LIS2, 480) IBEST, JREFL, HIT 480 FORMAT (/' PSIzero FOM for the ', I2, ' best solutions', * ' (with old solution numbers)', /, * ' (for ',I3, ' weak reflections and number of hits', * ' per reflection is ', F5.1, '):', /, * ' PSIzero(1) = sum |sum(E(K) * E(H-K))| / sum(sum|', * 'E(K) * E(H-K)|)', /, * ' PSIzero(2) = sum |sum(E(K) * E(H-K))| / sum(sum|', * 'E(K) * E(H-K)|**2)**1/2') WRITE (LIS2, FMT='(20X, ''PSI(1)'', 11X, ''PSI(2)'')') DO 490 J=1,IBEST DIF12 = DIF(1,J) / DIF(2,J) DIF13 = DIF(1,J) / DIF(3,J) DIF(1,J) = DIF12 DIF(2,J) = DIF13 P1SOL(J) = DIF12 490 P2SOL(J) = DIF13 CALL ORDTAB (P1SOL, IP1SOL, IBEST) CALL ORDTAB (P2SOL, IP2SOL, IBEST) P2MIN = P2SOL(1) DO 510 J=1,IBEST WRITE (LIS2, 500) J, P1SOL(J), IP1SOL(J), P2SOL(J), IP2SOL(J) 500 FORMAT (1X, I2, '. solution: ', 2(F9.4, ' - ', I2, 3X)) P1SOL(J) = P2MIN / DIF(2,J) 510 CONTINUE 530 CALL KETIME (LIS2) E4MIN = 0.0 NEGQ = 0 DO 621 I=1,N100-2 IF (NEGQ .GT. 500) GOTO 630 CALL KERNAI (IWEAK(1,I), IHPK, 3) NEQI = 1 CALL SYMEQ (IHPK, NEQI) IF (NEQI .NE. NNSYMM) GOTO 621 DO 560 INEQ=1,NEQI DO 560 I3=1,3 560 ICODEH(I3,INEQ) = ICODE(I3,INEQ) IPHPK = IWEAK(4,I) DO 622 II=I+1,N100-1 CALL KERNAI (IWEAK(1,II), IHPL, 3) NEQII = 1 CALL SYMEQ (IHPL, NEQII) IF (NEQII .NE. NNSYMM) GOTO 622 IPHPL = IWEAK(4,II) IPKPL = IPHPK + IPHPL IPKPL = MIN0 (IPKPL, 14-IPKPL) IF (IPHPK-IPHPL .EQ. 0) IPKPL = 0 DO 623 IIN=1,NEQII CALL KERNAI (ICODE(1,IIN), IHPL, 3) DO 624 III=II+1,N100 IF (.NOT. LAUEP .AND. IWEAK(4,III).NE.IPKPL) GOTO 624 CALL KERNAI (IWEAK(1,III), IKPL, 3) DO 620 IN=1,NEQI DO 570 I3=1,3 IHPK(I3) = ICODEH(I3,IN) IHML(I3) = IHPK(I3) - IKPL(I3) IL(I3) = IHPL(I3) - IHML(I3) IF (.NOT. LAUEP) GOTO 570 IF (MOD(IL(I3),2) .NE. 0) GOTO 620 570 IL(I3) = IL(I3) / 2 CALL GENERQ (IL, ISHL, IADL) IADL = ITAD(IADL) IF (IADL .EQ. 0) GOTO 620 DO 580 I3=1,3 580 IK(I3) = IKPL(I3) - IL(I3) CALL GENERQ (IK, ISHK, IADK) IADK = ITAD(IADK) IF (IADK .EQ. 0) GOTO 620 DO 590 I3=1,3 590 IH(I3) = IHPL(I3) - IL(I3) CALL GENERQ (IH, ISHH, IADH) IADH = ITAD(IADH) IF (IADH .EQ. 0) GOTO 620 DO 600 I3=1,3 600 IHKL(I3) = -IHPL(I3) - IK(I3) CALL GENERQ (IHKL, ISHHKL, IADHKL) IADHKL = ITAD(IADHKL) IF (IADHKL .EQ. 0) GOTO 620 NEGQ = NEGQ + 1 ISSH = ISIGN(1,ISHH) ISHH = IDEG(IABS(ISHH)) ISSK = ISIGN(1,ISHK) ISHK = IDEG(IABS(ISHK)) ISSL = ISIGN(1,ISHL) ISHL = IDEG(IABS(ISHL)) ISSHKL = ISIGN(1,ISHHKL) ISHHKL = IDEG(IABS(ISHHKL)) DO 610 J=1,IBEST EH = FLOAT (ITAB25(2,IADH,J)) / 1000. EK = FLOAT (ITAB25(2,IADK,J)) / 1000. EL = FLOAT (ITAB25(2,IADL,J)) / 1000. EHKL = FLOAT (ITAB25(2,IADHKL,J)) / 1000. E4 = EH * EK * EL * EHKL IF (E4 .LT. E4MIN) GOTO 610 IPH = ISSH * (ITAB25(3,IADH,J) + ISHH) IPK = ISSK * (ITAB25(3,IADK,J) + ISHK) IPL = ISSL * (ITAB25(3,IADL,J) + ISHL) IPHKL = ISSHKL * (ITAB25(3,IADHKL,J) + ISHHKL) IPH4 = IPH + IPK + IPL + IPHKL IPH4 = MOD(IPH4, 360) IF (IPH4 .LE. 0) IPH4 = 360 + IPH4 ICOS4 = ISCT(450-IPH4) COS4 = FLOAT(ICOS4) / 1000. ISIN4 = ISCT(IPH4) SIN4 = FLOAT(ISIN4) / 1000. E4 = SQRT((E4*COS4)**2 + (E4*SIN4)**2) QEST(1,J) = QEST(1,J) + E4*COS4 QEST(2,J) = QEST(2,J) + E4 QEST(3,J) = QEST(3,J) + E4*ABS(180.-FLOAT(IPH4)) 610 CONTINUE 620 CONTINUE 624 CONTINUE 623 CONTINUE 622 CONTINUE 621 CONTINUE GOTO 631 630 WRITE (LIS2, FMT='(/'' Negative quartet generation is stopped'', * '' at weak refl. No.'', I3, 2X, 3I4)') I, (IWEAK(I3,I), I3=1,3) 631 IF (NEGQ .LT. 5) THEN WRITE (LIS2, 640) NEGQ 640 FORMAT (/' Sorry, Negative Quartet FOM not possible, there', * ' are only ', I1, ' hits ') IF (.NOT. PSIZ) RETURN CALL KERNZA (0.0, Q1SOL, IBEST) GOTO 690 ENDIF WRITE (LIS1, 645) N100, NEGQ 645 FORMAT (' The ', I3, ' weakest reflections take part in', I5, * ' negative quartets.' ) WRITE (LIS2, 650) N100, NEGQ 650 FORMAT (/' The ', I3, ' weakest reflections take part in', I4, * ' negative quartets.' / * ' Negative quartet FOMs (with old solution numbers):', /, * ' Hauptman: NQEST = sum (E4 * cos(PH4)) / sum E4 ', * ' (here: NQEST + 1)', /, * ' Schenk: NQC = sum (E4 * |180-PH4|) ', * ' (here: NQC / sum E4 * 180)', /, * 20X, 'NQEST', 11X, 'NQC') DO 660 J=1,IBEST QEST(1,J) = 1. + QEST(1,J) / QEST(2,J) QEST(2,J) = QEST(3,J) / (QEST(2,J) * 180.) Q1SOL(J) = QEST(1,J) 660 Q2SOL(J) = QEST(2,J) CALL ORDTAB (Q1SOL, IQ1SOL, IBEST) CALL ORDTAB (Q2SOL, IQ2SOL, IBEST) Q1MIN = Q1SOL(1) Q2MIN = Q2SOL(1) DO 680 J=1,IBEST WRITE (LIS2, 670) J, Q1SOL(J), IQ1SOL(J), Q2SOL(J), IQ2SOL(J) 670 FORMAT (I3, '. solution: ', 2(F9.4, ' - ', I2, 3X)) Q1SOL(J) = (Q1MIN/QEST(1,J) + Q2MIN/QEST(2,J)) / 2. 680 CONTINUE 690 IPQSOL(1) = NREL IPQSOL(2) = NEGQ CALL COMFOM (P1SOL, Q1SOL, IPQSOL, IBEST) ILINK = IPQSOL(1) WRITE (LIS2, FMT='( '' Combined FOM: best solution is solution'', * '' No. '', I3)') ILINK FIRST = .FALSE. CALL KETIME (LIS2) RETURN END SUBROUTINE GENERP (IH, IK, IADR, ISHMK) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 PARAMETER (ISIZ = 59876) INTEGER *2 ITAB(ISIZ) DIMENSION IH(3), IK(3), IHMK(3) IADR = -1 DO 200 I=1,3 IHMK(I) = IH(I) - IK(I) 200 IF (IABS(IHMK(I)) .GT. MAXHKL(I)) GOTO 230 ICOHMK = INPACK(IHMK) KC = IABS(ICOHMK) IF (KC.EQ.0 .OR. KC.GT.MCT) GOTO 230 K = ITAB(KC) IF (K .EQ. 0) GOTO 230 L = IABS(K) / 4096 ISHMK = (L + 1) * ISIGN(1,K) * ISIGN(1,ICOHMK) IADR = IABS(K) - 4096*L 230 RETURN END SUBROUTINE GENERQ (IHKL, ISHIFT, IADR) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON / DIFTA0 / ITAB, MCT, NCT, ICR, MARKA4, ISTO4, INCA4,MAXA4, * NR, MCH, MCK, I34, I35, MAXHKL(3), IPG2(8), * E000R, IDC, NC, ESTART(5), ESTAR1, TO(3), KORIS, * QEET, MAXT, MCTLAT, IICENT, MS, NGN, NSP, * E2ALE, E2CLE, E2AGE, E2CGE, E2AG(7), E2CG(7), * IDC3, PSQ, IPSQ, E1MIN, E1100 PARAMETER (ISIZ = 59876) INTEGER *2 ITAB(ISIZ) DIMENSION IHKL(3) IADR = -1 DO 210 I=1,3 210 IF (IABS(IHKL(I)) .GT. MAXHKL(I)) GOTO 230 ICODE = INPACK(IHKL) KC = IABS(ICODE) IF (KC.EQ.0 .OR. KC.GT.MCT) GOTO 230 K = ITAB(KC) IF (K .EQ. 0) GOTO 230 L = IABS(K) / 4096 ISHIFT = (L + 1) * ISIGN(1,K) * ISIGN(1,ICODE) IADR = IABS(K) - 4096*L 230 RETURN END SUBROUTINE ORDTAB (URD, IORD, IOMAX) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH PARAMETER (IMAX = 25) DIMENSION URD(IMAX), IORD(IMAX), ORD(IMAX) IOMAX = MIN0 (IOMAX, MIN0 (IOMAX,IMAX)) CALL KERNZI (0, IORD, IOMAX) CALL KERNZA (0., ORD, IOMAX) JJ = 1 DO 250 I=1,IOMAX IF (I .EQ. 1) GOTO 240 DO 210 J=1,I-1 IF (URD(I) .GT. ORD(J)) GOTO 210 JJ = J GOTO 220 210 CONTINUE JJ = I GOTO 240 220 DO 230 K=I,JJ+1,-1 ORD(K) = ORD(K-1) 230 IORD(K) = IORD(K-1) 240 ORD(JJ) = URD(I) IORD(JJ) = I 250 CONTINUE CALL KERNAB (ORD(1), URD(1), IOMAX) RETURN END SUBROUTINE COMFOM (P1SOL, Q1SOL, IPQSOL, IBEST) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH EQUIVALENCE (LIS2, IFILE(8)) COMMON / DIFTA1 / ITAB5, ISTO5, INCA5, ISTA4, ISTA42, MAXA4N, * JSYMB, FAK, FAKWS, REDUS, KBMAX, * KB10X(15,25), KB10XX(15,25) PARAMETER (ISIZ5 = 10000) INTEGER *2 ITAB5(5*ISIZ5) LOGICAL REDUS PARAMETER (IBEMAX = 25) DIMENSION P1SOL(IBEMAX), Q1SOL(IBEMAX), IPQSOL(IBEMAX), * C1SOL(IBEMAX), C2SOL(IBEMAX), C3SOL(IBEMAX), * CFSOL(IBEMAX) DATA WC1, WC2, WPSI, WNEQ / 2., 4., 4., 6. / IF (IPQSOL(1) .LT. 20) WPSI = 2. IF (IPQSOL(1) .EQ. 0) WPSI = 0. IF (IPQSOL(2) .GT. 290) WNEQ = 7. IF (IPQSOL(2) .LT. 20) WNEQ = 2. IF (IPQSOL(2) .LT. 5) WNEQ = 0. WSUM = WC1 + WC2 + WPSI + WNEQ WC1 = WC1 / WSUM WC2 = WC2 / WSUM WPSI = WPSI / WSUM WNEQ = WNEQ / WSUM CALL KERNZI (0, IPQSOL, IBEST) DO 200 I=1,IBEST C1SOL(I) = FLOAT(KB10X(12,I)) / 1000. C2SOL(I) = FLOAT(KB10X(13,I)) / 1000. 200 CFSOL(I) = C1SOL(I) * WC1 + C2SOL(I) * WC2 + * P1SOL(I) * WPSI + Q1SOL(I) * WNEQ CALL KERNZA (0., C3SOL, IBEST) JJ = 1 DO 250 I=1,IBEST IF (I .EQ. 1) GOTO 240 DO 210 J=1,I-1 IF (CFSOL(I) .LT. C3SOL(J)) GOTO 210 JJ = J GOTO 220 210 CONTINUE JJ = I GOTO 240 220 DO 230 K=I,JJ+1,-1 C3SOL(K) = C3SOL(K-1) 230 IPQSOL(K) = IPQSOL(K-1) 240 IPQSOL(JJ) = I C3SOL(JJ) = CFSOL(I) 250 CONTINUE CALL KERNZA (0., C3SOL, IBEST) DO 260 I=1,IBEST 260 C3SOL(IPQSOL(I)) = FLOAT(I) CALL KERF2I (C3SOL, IPQSOL, IBEST) WRITE (LIS2, FMT = '('' Combined FOM:'', /, * '' CONS1 CONS2 PSI0 NEQ ''/ * '' Rel.weights '', 4F8.3 / * '' No orig.No'' , 40X, ''CFOM Range'')') * WC1, WC2, WPSI, WNEQ IPQMIN = IBEST DO 270 J=1,IBEST IF (IPQSOL(J) .LT. IPQSOL(IPQMIN)) IPQMIN = J N = KB10X(11,J) 270 WRITE (LIS2, 280) J, N, C1SOL(J), C2SOL(J), P1SOL(J), Q1SOL(J), * CFSOL(J), IPQSOL(J) 280 FORMAT (I3, I6, F13.3, 4F8.3, I4) IPQSOL(1) = IPQMIN RETURN END