PROGRAM DDMAIN *************************************** DDMAIN FORTRAN = DDMAIN.FOR *** prepare input files for FOUR, etc. Last update: 11 Nov. 1999 *** includes MERBIN, FCALC, AUTOFR ... Design: SGG 1987 CS 1988 *************************************** 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) EQUIVALENCE (LIS2, IFILE(8)), (ICRYS, IFILE(3)) CALL KEPROG ('DDMAIN') WRITE (LIS2, FMT = '('' Last DDMAIN update: 11 Nov. 1999'')') KEYS(19) = 4 CALL DDMINI (KEYD) IDDOKA = KEYS(10) IF (IDDOKA .EQ. 17) GOTO 999 IF (KEYD .EQ. 9) GOTO 900 CALL DICALC IF (KEYD .EQ. 2 .OR. KEYD .EQ. 3) CALL WISSEN 900 CALL FILCLO (ICRYS, 'KEEP') CALL KEPROX 999 CONTINUE WRITE (LIS2, FMT='(/'' Test: DDOKA exit MAIN SUBPROGRAM ''/)') STOP 99 END SUBROUTINE DDMINI (KEYDQ) 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 EQUIVALENCE (IDDL, IFILE(1)), (IATOMS, IFILE(2)) EQUIVALENCE (IDDS, IFILE(1)), (ICRYS,IFILE(3)) EQUIVALENCE (ICON, IFILE(4)), (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IPR1, IFILE(6)) EQUIVALENCE (IATOLD, IFILE(10)) EQUIVALENCE (IBINFO, IFILE(11)), (IBINFC, IFILE(12)) EQUIVALENCE (IBINDU, IFILE(14)), (IBINDI, IFILE(15)) EQUIVALENCE (IBINFF, IFILE(16)) EQUIVALENCE (NRECYR, KEYS(11)), (KEYWIL, KEYS(12)) LOGICAL SWPRI, EXPAND, SWRECY, NORECY, LSC98 EQUIVALENCE (SWPRI, SWITCH(10)), (EXPAND, SWITCH(23)) EQUIVALENCE (SWRECY, SWITCH(17)), (NORECY, SWITCH(18)) EQUIVALENCE (LSC98, SWITCH(19)) 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 /CRYSB/ SPGR, WAVEAT, CELATY(10) CHARACTER SPGR *16, WAVEAT *2, CELATY *2 COMMON /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) DIMENSION FITFO(3), FITFC(2), FITFC2(51) EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1)) PARAMETER (MAXAT = 993) PARAMETER (MAXBUF = 198) COMMON / / SICO(12500), FF(500,10), EXPBP(500), EXPBR(500), * SUMF2(500), SUMF2P(500), SFAC(13,10), * ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT, * BUFFO(MAXBUF), BUFFC(MAXBUF), BUFBUF(MAXBUF) DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) COMMON /ATNAMA/ ATNAME(MAXAT) CHARACTER * 6 ATNAME COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV, * SUMX, SUMY, SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2, * NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF, * KEYT, KEYRET, JCODE, SUMF2R, Y, X, XSIG, * ITP, E1, E2, KEYDX, KEYDS, * NITFO, NITFC, NITDUA, NITDIF, NITFFT, * KENDFO, KENDFC, KENDUA, KENDIF, KENDFF, * FITDUA(7), FITDIF(4), FITFFT(5), * BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF) DIMENSION BUFFOX(10) DIMENSION HCON(3) DIMENSION MHKL(3) DIMENSION R2CYC(20), R2CYCA(20) PARAMETER (LCMAX = 10) CHARACTER * 6 LCONDA(LCMAX) DATA LCONDA / 'DDMAIN', 'OPTION', 'DIRP1', 'PRINT', 'EXPAND', * 'SCALE' , 'BBB' , 'STLMAX', 'WILSON', 'MAXHKL' / DATA SCALX, BPX, BRX, SCALAT / -1., -1., -1., -1. / DATA MHKL / 0, 0, 0 / DATA BPOLD / 0.0 / , NATL /0/ CALL KERNZA (0.0, BUFFC, MAXBUF) IF (LIT(3).EQ.'NORECY' .OR. LIT(2).EQ.'NORECY') NORECY = .TRUE. NRECYR = 0 CALL RDCRYS (ICRYS) DO 110 I=1,NTYPE 110 BUFFO(I) = CELALL(I) / ZET I = NTYPE J = NINT(ZET) WRITE (LIS2, 114) J, (CELATY(K), BUFFO(K), K=1,I) 114 FORMAT (' Z:', I3 / ' FORMUL:', 6(2X,A2,F6.1) / * ( 8X, 6(2X,A2,F6.1))) CALL KERNZA ( 9999., HCON, 3) CALL KERNZA ( 0., HKLMAX, 3) STLCON = 9999.9 STLMAX = 0.0 BUFFFT(30) = 0. BUFFFT(31) = 0. KEYOK = 0 BOV = 2.0 BP = BOV BR = BOV SCALE = 1. KEYD = -1 KEYWIL = 0 120 CALL RDCOND (ICON, LCONDA, LCMAX, KEND) GOTO (120, 2, 3, 120, 3, 6, 7, 8, 9, 10), KEND IF (KEND.EQ.0) GOTO 140 122 CALL KERROR ('No option given or wrong data', 120, 'DDMINI') 2 IF (NFNUM.LE.0) CALL KERROR * ('No OPTION number given in CONDA file', 2, 'DDMINI') KEYD = NINT(FNUM(1)) KEYDQ = KEYD IF (KEYD.GT.9 .OR. KEYD.LT.0) CALL KERROR ('Wrong option given', * 2, 'DDMINI') IF (KEYD .GE. 5) THEN WRITE (LIS1, FMT='('' DDMAIN input OPTION :'', I2)') KEYD ENDIF IF (KEYD .EQ. 1 .AND. LIT(3) .EQ. 'OK') KEYOK = 1 KEYDS = NINT(FNUM(2)) NRECY = NINT(FNUM(3)) NATL = NINT(FNUM(4)) IF (NRECY .LE. 0) GOTO 120 SWRECY = .TRUE. NRECYR = NRECY / 10 + 1 IF (KEYD.EQ.1 .OR. KEYD.EQ.3) WRITE (CHOUT, FMT= * '(34X, '' prepare for PHASEX-/-Fourier cycle'', I3)') NRECYR CALL SHOUT KEYWIL = 4 GOTO 120 3 EXPAND = .TRUE. KEYWIL = 4 WRITE (LIS2, 123) 123 FORMAT (' EXPAND data to P1 symmetry (or centered equivalent)') GOTO 120 6 IF (NFNUM.NE.1) CALL KERNER (6, 'DDMINI') IF (FNUM(1) .LT. 0.0001) GOTO 120 SCALE = FNUM(1) WRITE (LIS2, 125) SCALE 125 FORMAT (' Scale from CONDA file: Scale =', F9.5) KEYWIL = 4 GOTO 120 7 IF (NFNUM.LT.1) CALL KERNER (7, 'DDMINI') IF (FNUM(1).GT.0.0001) THEN BOV = FNUM(1) BP = BOV BR = BOV ENDIF IF (FNUM(2).GT.0.0001) BP = FNUM(2) IF (FNUM(3).GT.0.0001) BR = FNUM(3) WRITE (LIS1, 126) FNUM(1), FNUM(2), FNUM(3) 126 FORMAT (' Temp. factors from CONDA: Bov=', * F6.3, ' Bp =', F6.3, ' Br =', F6.3) WRITE (LIS1, 127) BOV, BP, BR 127 FORMAT (' Temp. factors used : Bov=', * F6.3, ' Bp =', F6.3, ' Br =', F6.3) KEYWIL = 4 GOTO 120 8 IF (NFNUM.NE.1) CALL KERNER (8, 'DDMINI') STLMAX = FNUM(1) WRITE (LIS1, 128) STLMAX WRITE (LIS2, 128) STLMAX 128 FORMAT (' Skip reflections if sin(th)/lambda >', F8.4) GOTO 120 9 IF (NLIT.EQ.1) GOTO 120 IF (NLIT.EQ.2 .AND. LIT(2).EQ.'NO') THEN KEYWIL = 4 WRITE (LIS2, 130) 130 FORMAT (' No WILSON-PARTHASARATY plot nor WILSON-BpBr-plot') ELSEIF (NLIT.EQ.2 .AND. LIT(2).EQ.'PARTHA') THEN KEYWIL = -2 WRITE (LIS2, 133) 133 FORMAT (' Only WILSON-PARTHASARATY plot, no WILSON-BpBr-plot') ELSEIF (NLIT.EQ.3 .AND. LIT(2).EQ.'FIX' .AND. * LIT(3).EQ.'BP') THEN KEYWIL = 1 ELSEIF (NLIT.EQ.3 .AND. LIT(2).EQ.'FIX' .AND. * LIT(3).EQ.'BR') THEN KEYWIL = 2 ELSEIF (NLIT.EQ.4 .AND. LIT(2).EQ.'FIX' .AND. * (LIT(3).EQ.'BP' .OR. LIT(4).EQ.'BP') .AND. * (LIT(4).EQ.'BR' .OR. LIT(3).EQ.'BR')) THEN KEYWIL = 3 ELSE CALL KERNER (9, 'DDMINI') ENDIF GOTO 120 10 IF (NFNUM.NE.3) CALL KERROR ('MAXHKL input error', 10, 'DDMINI') J = 0 DO 137 I = 1, 3 K = NINT(FNUM(I)) IF (K .LT. 0) K = 0 MHKL(I) = K 137 CONTINUE IF (J .EQ. 0) GOTO 120 WRITE (LIS1, 138) MHKL 138 FORMAT (' Skip reflections if indices exceed MAXHKL =', 3I3) CALL KERI2F (MHKL, HKLMAX, 3) GOTO 120 140 IF (KEYD .LT. 0) GOTO 122 CALL FILCLO (ICON, 'KEEP') IF (NRECYR .GT. 0) GOTO 141 CALL FILINQ (IBINFO, 'BINFO', 'UNFORMATTED', 'INPUT', KINQU) IF (KINQU.NE.0 .OR. KEYD.EQ.9) CALL MERBIN IF (KEYD .EQ. 9) RETURN 141 CALL LOGRD (IDDL, 'MERBSC', KLOG) IF (KLOG .LT. 0 .OR. LIT(2) .NE. 'SCALE') THEN CHOUT=' MERBIN SCALE not found on DDLOG file: rerun MERBIN' CALL SHOUT CALL MERBIN GOTO 141 ENDIF SCALE = FNUM(2) BOV = FNUM(3) BP = BOV BR = BOV WRITE (LIS2, 142) SCALE, BOV 142 FORMAT (' Data from DDLOG: Scale =', F9.5, ' Bov:', F6.3) CALL LOGRD (IDDL, 'NREF', KLOG) IF (KLOG .LT. 0 .OR. FNUM(2) .LT. 0.9) THEN CHOUT=' Nr. of refl. not found on DDLOG file: what happened?' CALL SHOUT CALL KERROR ('You cleared too much, probably!', 114, 'DDMINI') ENDIF NREFL = NINT(FNUM(2)) CALL LOGRD (IDDL, 'BP', KLOG) IF (KLOG.GT.0) THEN SCALX = FNUM(2) BPX = FNUM(3) BRX = FNUM(4) ENDIF CALL FILCLO (IDDL, 'KEEP') CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO) IF (STLMAX.LT.0.0001 .OR. STLMAX.GT.BUFFO(6)) STLMAX = BUFFO(6) CALL KERNAB (BUFFO(7), HKLMAX, 3) DO 7142 I = 1,3 IF (MHKL(I) .LE. 0) GOTO 7142 F123 = MHKL(I) IF (F123 .LT. HKLMAX(I) ) HKLMAX(I) = F123 7142 CONTINUE CALL KERNAB (BUFFO(5), BUFFC(5), MAXBUF - 4) IF (KEYD .NE. 4) GOTO 143 NAT = 1 KEYT = 1 CALL KERNZA (0., ATXYZ, 10) IZAT(1) = 1 ATNAME(1) = 'H' CALL FCALCI (KEYT, ATXYZ, IZAT, ITAT, NAT) CALL KERNAB (BUFFO(5), BUFFFT(5), 23) BUFFFT(28) = 2. IF (KEYDS .EQ. 1) BUFFFT(28) = 6. GOTO 935 143 CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ) IF (KINQ.EQ.-1) CALL KERROR (' No ATOMS file found', * 143, 'DDMINI') CALL KERINA (IATOMS, LIT, 1, LEND) IF (LIT(1) .NE. 'ATOMS') CALL KERROR * (' Incorrect header on ATOMS file', 143, 'DDMINI') REWIND IATOMS NSET = 0 CALL ATIN7 (NSET) IF (NSET .NE. 1) CALL KERROR ('Kan niet', 143, 'DDMINI') IF (NFNUM .GT. 0) THEN IF (LIT(NLIT). EQ. 'SC=' .AND. * FNUM(NFNUM) .GT. 0.0001) SCALAT = FNUM(NFNUM) ENDIF NATINP = NAT IF (KEYT .EQ. 3 .AND. EXPAND) CALL KERROR * ('EXPAND with anisotropic temp.f. not permitted', 143, 'DDMINI') IF (KEYT .EQ. 2 .AND. EXPAND) THEN WRITE (LIS1, FMT='('' Ignore individual temp. factors'')') KEYT = 1 DO 145 I = 1, NAT 145 ATXYZ(5,I) = 0.0 ENDIF IF (KEYD .EQ. 2 .OR. SWRECY) THEN KEYWIL = 4 IF (SCALX .GT. 0.0) THEN SCALE = SCALX BP = BPX BR = BRX ENDIF ENDIF IF (SWITCH(1)) WRITE (LIS2, 147) SCALE, BP, BR 147 FORMAT (' PTB TEMP: SCALE, BP, BR =', F8.4, 2F6.3) IF (NRECYR .GE. 3 .AND. SCALAT .GT. 0.) THEN SCALE = SCALAT IF (SWITCH(1)) WRITE (LIS2, 148) SCALE 148 FORMAT (' PTB TEMP: OLD SCALE (SCALAT) =', F8.4) ENDIF IF (KEYT .GE. 2) KEYWIL = 4 IF (KEYD.EQ.2) THEN CALL FILINQ (IBINDU, 'BINDUA', 'UNFORMATTED', 'INPUT', KINQU) CALL FILINQ (IBINDI, 'BINDIF', 'UNFORMATTED', 'INPUT', KINQI) IF (KINQU.EQ.-1 .OR. KINQI.EQ.-1) CALL KERROR * (' No BINDUA or BINDIF file found', 0, 'DDMAIN') CALL BINIFF (1,IBINDU,'BINDUA',FITDUA,NITDUA,BUFDUA,KENDUA) R2X = BUFDUA(7) WRITE (LIS2, FMT='('' R2X ='', F6.3)') R2X BUFFFT(30) = R2X CALL BINIFF (1,IBINDI,'BINDIF',FITDIF,NITDIF,BUFDIF,KENDIF) GOTO 255 ENDIF SCALEO = SCALE IF (.NOT. SWRECY) CALL ATOMPR (LIS1, 7, ATXYZ, ATNAME, IZAT, NAT) CALL ATOMPR (LIS2, 7, ATXYZ, ATNAME, IZAT, NAT) IF (KEYT.EQ.1) WRITE (LIS2, 155) 155 FORMAT (' Overall B or Bp used for struct.f. calculation') IF (KEYT.EQ.2) WRITE (LIS2, 156) 156 FORMAT (' Individual isotropic temp.f. on file: ignore overall B') IF (KEYT.EQ.3) WRITE (LIS2, 157) 157 FORMAT (' Mixed / anisotropic temp.factors used') BUFFC(16) = SCALE BUFFC(17) = BOV WRITE (LIS2, FMT='('' SCALE and temperature factors to'', * '' calculate structure factors Fp:'')') WRITE (LIS2, FMT='('' SCALE factor:'',22X,''SC ='', F8.3)') SCALE IF (KEYT .GT. 1) THEN WRITE (LIS2, 172) 172 FORMAT (' Use individual temp.factors for known atoms') BPOLD = BP BP = 0. GOTO 175 ENDIF WRITE (LIS2, 173) BP 173 FORMAT (' Overall temp.f. for known atoms: Bp =', F8.3) IF (ABS(BP-BR).LT.0.001) GOTO 180 175 WRITE (LIS2, 177) BR 177 FORMAT (' Overall temp.f. for unknown atoms: Br =', F8.3) 180 BUFFC(18) = SCALE BUFFC(19) = BP BUFFC(20) = BR BUFFC(21) = STLMAX CALL KERNAB (HKLMAX, BUFFC(22), 3) IF (KEYT.EQ.3 .AND. KEYD.GE.5) CALL KERROR * ('Anisotr.t.f. not allowed for AUTOR2 TEST', 180, 'DDMINI') IF (NRECYR .LE. 2) GOTO 7167 CALL KERNZI (0, IZTYPE, 10) DO 7157 J=1,NTYPE CALL ATOMIZ (CELATY(J), NLET, IZ) IZTYPE(J) = IZ 7157 CONTINUE CALL KERNZA (0.0, CELPAR, NTYPE) AAMULT = FLOAT(IMULT) DO 7161 I=1,NAT DO 7160 J=1,NTYPE IF (IZAT(I).NE.IZTYPE(J)) GOTO 7160 CELPAR(J) = CELPAR(J) + ATXYZ(4,I) * AAMULT 7160 CONTINUE 7161 CONTINUE IIII = 0 DO 7162 J=1,NTYPE IF ( ( IZTYPE(J) .GE. 10 .AND. CELPAR(J) .GT. CELALL(J) ) .OR. * (IZTYPE(J) .GE. 2 .AND. CELPAR(J) .GT. CELALL(J) .AND. * NRECYR .GE. 7) ) THEN CELALL(J) = CELPAR(J) IIII = 1 ENDIF 7162 CONTINUE IF (IIII .EQ. 0) GOTO 7167 DO 7165 I=1,NTYPE 7165 BUFFOX(I) = CELALL(I) / ZET J = NINT(ZET) WRITE (LIS1, 7166) J, (CELATY(K), BUFFOX(K), K=1,NTYPE) 7166 FORMAT (/' NOTE: Cell Contents reset [ output FOUR !! ] :'/ * ' Z:', I3 / ' FORMUL:', 6(2X,A2,F6.1) / * ( 8X, 6(2X,A2,F6.1))/) 7167 CONTINUE CALL FCALCI (KEYT, ATXYZ, IZAT, ITAT, NAT) IF (EXPAND) GOTO 183 IF (PSQ .LE. 1.0) THEN WRITE (CHOUT, FMT='('' Scattering fraction, p**2 = '', * F7.3)') PSQ CALL SHOUT2 ELSE IF (PSQ .LE. 1.3) THEN WRITE (CHOUT, FMT='( * '' Warning scattering fraction, p**2 = '', F7.3)') PSQ IF (PSQ .LT. 1.1) THEN CALL SHOUT2 ELSE CALL SHOUT WRITE(CHOUT,FMT='('' Note: this may cause errors'')') CALL SHOUT WRITE (CHOUT, FMT='('' Cell contents incorrect?'', * '' Reset p**2 to 1.0'')') CALL SHOUT WRITE(CHOUT,FMT='('' Call CRYSDA to modify contents'')') CALL SHOUT ENDIF PSQ = 1.0 ELSE WRITE (CHOUT, FMT='( * ''0Scattering fraction, p**2 = '', F7.3)') PSQ CALL SHOUT WRITE (LIS1, 8183) CCODE WRITE (IPR1, 8183) CCODE 8183 FORMAT (/' Too many atoms, or too many HEAVY atoms. '/ * ' -------------- Check your data:'/ * ' if the cell contents are incorrect: call CRYSDA, else:'/ * ' modify the contents of the ATOMS file !' / * ' If a complete molecule lies on a symmetry element:' / * ' remove the symmetry-redundent part of it, else:'/ * ' if FOUR recycling led to too many HEAVY atoms:' / * ' rename some of the HEAVY atoms to lower its Z value!'/ * ' Note: p**2 up to 1.3 is acceptable but may cause scaling'/ * ' errors. You should make p**2 = 1, approximately,'/ * ' and then we suggest to you to continue by calling:'/ * ' DIRDIF ', A6, ' NOFREE'/ * ' Good luck!'/) CALL KERROR ('Too many atoms input', 8183, 'DDMINI') ENDIF ENDIF 183 CONTINUE IF (KEYT .GT. 1) BP = BPOLD BPAV = BP IF (KEYT .NE. 3 .AND. .NOT.EXPAND) CALL FCALII (NSET) CALL LOGRD(IDDL, 'NAT=', KLOG) NATS = 0 IF (KLOG .GT. 0) NATS = NINT(FNUM(3)) CALL FILCLO (IDDL, 'KEEP') BUFFC(25) = NAT BUFFC(26) = P1SQ BUFFC(27) = PSQ IF (KEYD.EQ.6 .OR. KEYD.GE.8) CALL KERROR ('?', 200, 'DDMINI') IF (KEYD .GE. 5) KEYWIL = 4 IF (KEYWIL .EQ. 4) GOTO 190 IF (SWRECY .OR. NAT .GT. 20 .OR. PSQ .GT. .90) KEYWIL = -2 IZMAX = 1 DO 186 I = 1, NAT 186 IZMAX = MAX0 (IZMAX, IZAT(I)) IF (IZMAX .LT. 50 .AND. PSQ .GT. .80) KEYWIL = -2 IF (IZMAX .LT. 35 .AND. PSQ .GT. .70) KEYWIL = -2 IF (IZMAX .LT. 20 .AND. PSQ .GT. .60) KEYWIL = -2 IF (KEYWIL .EQ. 0) THEN IF (ABS (BP - BR) .GT. 0.001) * WRITE (LIS1, FMT='('' TEMP PTB BP, BR.?? '')') BPINP = BOV BRINP = BOV BP = BOV BR = BOV ENDIF 190 CONTINUE IF (ABS(BP - BR) .GT. .001) THEN WRITE (LIS2, 211) SCALE, BP, BR 211 FORMAT (' Scale and B-values to be used: Scale =', * F9.5, ' Bp =', F6.3, ' Br =', F6.3) ELSE WRITE (LIS2, 213) SCALE, BOV 213 FORMAT (' Scale and overall temp.f. to be used: Scale =', * F9.5, ' Bov:', F6.3) ENDIF IF (KEYD.EQ.0 .OR. KEYD.EQ.5 .OR. EXPAND .OR. NAT.EQ.1) THEN CALL FCALC (NSET) ELSEIF (KEYT .LT. 3) THEN CALL AUTOFR (NATS, NATL, NRECY, NSET) IDDOKA = KEYS(10) IF (IDDOKA .EQ. 17) RETURN ELSE CHOUT = ' AUTOFR is suppressed when using Anisotr.t.f. !' CALL SHOUT2 CALL FCALC (NSET) ENDIF IF (KEYD .EQ. 0) THEN CALL FILCLO (IATOMS, 'KEEP') CALL FILCLO (IBINFO, 'KEEP') CALL FILCLO (IBINFC, 'KEEP') CALL KEPROX RETURN ENDIF IF (KEYD .GE. 5) THEN CALL FILCLO (IATOMS, 'KEEP') CALL FILCLO (IBINFO, 'KEEP') CALL KEPROX RETURN ENDIF IF (KEYT .GT. 1) BP = 0 KEYS(17) = NAT KEYS(18) = NATL IF (.NOT.EXPAND .AND. .NOT.SWRECY) CALL SCALE7 R2X = BUFFFT(30) IF (NRECYR .EQ. 3 .AND. PSQ .GT. 0.90 .AND. R2X .LT. 0.30) THEN SCALE = SQRT (SUMFP2 / SUMFO2) WRITE (LIS2, 258) SCALE 258 FORMAT * (' $TE New scale = SQRT( (SUMFP2 + FF2R) / SUMFO2 ):', F11.5 * ,' accepted!') BUFFFT(31) = SCALE SCALEO = SCALE ENDIF NRECYS = MOD (NRECY, 10) CALL LOGRD (IDDL, 'SCALEX', KLOG) CALL FILCLO (IDDL, 'KEEP') IF (KLOG .GT. 0) THEN IRUN = NINT (FNUM(2)) IICY = NINT (FNUM(3)) IF (IRUN .EQ. KEYS(13) .AND. IICY+1 .EQ. NRECYR) THEN SCALE = FNUM(4) WRITE (LIS2, 217) SCALE 217 FORMAT (' $TE DDMAIN: Old scale from QPPQQ (FOUR):', F11.5 * ,' accepted!') BUFFFT(31) = SCALE SCALEO = SCALE GOTO 219 ENDIF ENDIF IF (NRECYS .GE. 6) THEN WRITE (LIS2, * FMT='('' $TE Old scale retained: '', F11.5)') SCALE BUFFFT(31) = SCALE ELSEIF (LSC98) THEN SCALE = SQRT (SUMFP2 / SUMFO2) WRITE (LIS2, 218) SCALE 218 FORMAT (' $TE New scale = SQRT( SUMFC2 / SUMFO2 ):', F11.5 * ,' accepted!') BUFFFT(31) = SCALE SCALEO = SCALE ENDIF 219 CONTINUE IF (NAT .GT. 499) GOTO 254 IF (KEYT .GT. 1 .AND. ABS(SCALE-SCALEO) .LT. 0.00001) THEN IF (NAT .EQ. NATINP) GOTO 254 GOTO 251 ENDIF CHOUT = 'New scale supplied by DDMAIN' IF (KEYT .EQ. 1) THEN IF (.NOT. EXPAND .AND. KEYD.EQ.1) CALL SCASTA DO 233 I = 1, NAT ATXYZ(6,I) = 0.0 233 ATXYZ(5,I) = BP CHOUT = 'B-isotr supplied by DDMAIN' ENDIF 251 CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ) IF (.NOT. EXPAND) CALL ATOMOC (2, ATXYZ, IZAT, NAT) IT = MAX0 (0, 10000 * (ITIME(1)-1900) + 100 * ITIME(2) + ITIME(3)) WRITE (CHOUT, 7102) CCODE, IT, KEYS(13), NRECYR, R2X, SCALE 7102 FORMAT ('ATOMS ', A6, ' < DDMAIN dd', I7, * ' RUN', I4, ' CY=', I3, ' R2=', F6.3, ' SC=', F10.6 ) WRITE (IATOMS, FMT = '(A72)') CHOUT IF (NRECYR .GT. 1) WRITE (IATOMS, 799) NRECYR 799 FORMAT ('REMARK DDMAIN, some atoms rejected, CYCLE', I3 ) IF (NRECYR .EQ. 0 .AND. .NOT. NORECY) WRITE (IATOMS, FMT= * '(''REMARK DDMAIN, input atoms, start CYCLE 1'' )') DO 252 NATR = 1, NAT 252 CALL ATOMWB (IATOMS, ATXYZ, ATNAME, NATR) WRITE (LIS2, 253) NAT 253 FORMAT (' Number of atoms written to ATOMS file:', I4) WRITE (IATOMS, FMT = '(''END'')') CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD') 254 CALL FILCLO (IATOMS, 'KEEP') IF (NRECYR .LE. 5) GOTO 739 CALL GETR2X (0, IATOLD, KEYS(13), R2CYC, KEND) WRITE (LIS2, FMT='('' TEMP99 KEND'', I3)') KEND IF (KEND .LE. 0) GOTO 739 CALL KERNZA (-1.0, R2CYCA, 20) NCY = KEND+1 R2CYC(NCY) = R2X R2MIN = 9.999 NR2MIN = NCY DO 733 N = 3, NCY IF (R2CYC(N) .LT. R2MIN) THEN NR2MIN = N R2MIN = R2CYC(N) ENDIF IF( R2CYC(N-2).GT.0. .AND. R2CYC(N-1).GT.0. .AND. R2CYC(N).GT.0.) * R2CYCA(N) = ( R2CYC(N-2) + R2CYC(N-1) + R2CYC(N) ) / 3. 733 CONTINUE WRITE (LIS2, 734) (R2CYC(I), I=1,NCY) 734 FORMAT (/' R2 values: ', 20F6.3) WRITE (LIS2, 735) (R2CYCA(I), I=1,NCY) 735 FORMAT ( ' Smoothed : ', 20F6.3) IF (R2CYCA(NCY) .LT. R2CYCA(NCY-1)) GOTO 739 IF (R2X .LT. 1.01 * R2MIN) GOTO 739 IF (R2X .LT. R2CYCA(NCY-1)) GOTO 739 IF (R2X .LT. 1.1 * R2CYCA(NCY-1) .AND. NRECYR .LE. 8 .AND. * R2X .LT. 1.1 * R2CYCA(NCY-2)) GOTO 739 CHOUT = ' The R2 value increases, the refinement is not stable ' CALL SHOUT CALL GETR2X (NR2MIN, IATOLD, KEYS(13), R2CYC, KEND) IF (KEND .LE. 0) GOTO 739 CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ) 736 READ (IATOLD, FMT='(A80)', END= 737) CHIN WRITE (IATOMS, FMT='(A80)' ) CHIN IF (CHIN(1:4) .NE. 'END ') GOTO 736 737 READ (IATOLD, FMT='(A80)', END= 1737) CHIN IF (CHIN(1:6) .NE. 'ATOMS ') GOTO 737 CALL KERINB (LIT, 1) IF (LIT(4) .NE. 'DDMAIN') GOTO 1737 REWIND IATOMS WRITE (IATOMS, FMT='(A80)' ) CHIN 2736 READ (IATOLD, FMT='(A80)', END= 1737) CHIN WRITE (IATOMS, FMT='(A80)' ) CHIN IF (CHIN(1:4) .NE. 'END ') GOTO 2736 1737 CALL FILCLO (IATOMS, 'KEEP') CALL FILCLO (IATOLD, 'KEEP') CHOUT = ' The atoms set with the lowest R2 value retrieved' CALL SHOUT IF (R2MIN .GT. .50) THEN CHOUT = ' The R2 value is too high anyhow: stop.' CALL SHOUT CALL KERROR (' Wrong model used ?', 1737, 'DDMINI') ENDIF CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KIDDS) WRITE (IDDS, FMT='(''DDMAIN''/ ''FOUR''/ ''NUTS''/ ''STOP'')') REWIND IDDS CALL FILCLO (IDDS, 'KEEP') CHOUT = ' CALL DDMAINX NORECY NOFREE ' CALL LOGWR (IDDL) CALL FILINQ (ICON, 'CONDA', 'FORMATTED', 'OUTPUT', KINQCO) WRITE (ICON, 630) CCODE, (ITIME(IT), IT=1,3) 630 FORMAT ('CONDA ', A6, I7,2I4) WRITE (ICON, FMT='(''PROGRAM DDMAIN''/ * ''OPTION 3 FOUR ''/ * ''PROGRAM FOUR ''/ ''NORECY''/ * ''PROGRAM NUTS AT2X'' / ''FINISH'')' ) CALL FILCLO (ICON, 'KEEP') CALL KEPROX RETURN 739 CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO) 255 IF (.NOT. EXPAND) THEN CALL BINIFF (1, IBINFC, 'BINFC', FITFC, NITFC, BUFFC,KENDFC) ELSE CALL BINIFF (1, IBINFC, 'BINFC2', FITFC2, NITFC, BUFFC,KENDFC) ENDIF CALL KERNAB (BUFFC(7), HKLMAX, 3) P1SQ = BUFFC(26) PSQ = BUFFC(27) PSQX = PSQ IF (EXPAND) PSQX = P1SQ BPINP = BUFFC(19) BRINP = BUFFC(20) STLMAX = BUFFC(21) BUFFC(16) = SCALE BUFFC(17) = BOV IF (KEYD .EQ. 2) THEN CALL FCALCI (KEYT, ATXYZ, IZAT, ITAT, NAT) ENDIF IF (KEYD .NE. 1) GOTO 270 IF (IFIX (100.0 * PSQX) .LT. MAX0(79, 100- 3*NAT) * - MIN0(4, NAT/6) ) GOTO 270 IF (KEYOK .EQ. 1) THEN WRITE (LIS1, FMT='( * '' Warning: PHASEX requested with rather large PSQ'')') GOTO 270 ENDIF CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ) IF (KINQ.EQ.-1) CALL KERROR ('No DDSYST file found',0,'DDMAIN') LITFFT = 0 261 READ (IDDS, FMT='(A6)') LIT(1) IF (LIT(1) .EQ. 'FOUR') LITFFT = 1 IF (LIT(1) .NE. 'STOP') GOTO 261 REWIND IDDS IF (LITFFT .EQ. 1) THEN IF (.NOT. SWRECY) WRITE (LIS1, 262) IF (.NOT. SWRECY) WRITE (LIS2, 262) 262 FORMAT (/' The scattering power is too large', * ' therefore program PHASEX is not' / * ' applied and program FOUR follows.'/) WRITE (IDDS, FMT='(''FOUR'' / ''NUTS'' )') ENDIF WRITE (IDDS, FMT='(''STOP'')') REWIND IDDS CALL FILCLO (IDDS, 'KEEP') KEYD = 3 KEYDS = 0 270 IF (KEYT .GT. 1) BP = 0.0 IF (KEYD.EQ.3 .AND. KEYDS.GE.3) GOTO 310 IF (KEYD .EQ. 2) GOTO 310 IF (.NOT.EXPAND) CALL FCALII (0) IF (KEYD .NE. 1) GOTO 310 RDENR = 0 RNUMR = 0 DO 290 I=1,NTYPE RDENR = RDENR + (CELALL(I)-CELPAR(I))*IZTYPE(I)**2 290 RNUMR = RNUMR + (CELALL(I)-CELPAR(I))*IZTYPE(I)**3 E000R = (RDENR**1.5) / RNUMR / SQRT(ALATT) NITDUA = 7 BUFDUA(5) = E000R BUFDUA(6) = PSQ IF (EXPAND) BUFDUA(6) = P1SQ BUFDUA(7) = R2X CALL BINOFF (7, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA) RETURN 310 IEF = 1 IF (KEYD.EQ.3 .AND. KEYDS.EQ.5) IEF = -1 BUFFC(18) = SCALE BUFFC(19) = BP BUFFC(20) = BR CALL KERNAB (BUFFC(5), BUFFFT(5), 23) BUFFFT(28) = 3. IF (IEF.EQ.-1) BUFFFT(28) = 4. 935 IF (EXPAND) BUFFFT(28)= 1. BUFFFT(29) = KEYD * 10 + KEYDS WRITE (LIS2, FMT='('' $TEMP R2 = '', F6.3)') BUFFFT(30) NITFFT = 5 IF (BUFFFT(30) .GT. 9.999) BUFFFT(30) = 9.999 CALL BINOFF (31, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT,KENDFF) RETURN END SUBROUTINE ATIN7 (NSET) 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 EQUIVALENCE (IATOMS, IFILE(2)) EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) LOGICAL NIJM EQUIVALENCE (NIJM, SWITCH(1)) 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 /CRYSB/ SPGR, WAVEAT, CELATY(10) CHARACTER SPGR *16, WAVEAT *2, CELATY *2 COMMON /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) DIMENSION FITFO(3), FITFC(2), FITFC2(51) EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1)) PARAMETER (MAXAT = 993) PARAMETER (MAXBUF = 198) COMMON / / SICO(12500), FF(500,10), EXPBP(500), EXPBR(500), * SUMF2(500), SUMF2P(500), SFAC(13,10), * ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT, * BUFFO(MAXBUF), BUFFC(MAXBUF), BUFBUF(MAXBUF) DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) COMMON /ATNAMA/ ATNAME(MAXAT) CHARACTER * 6 ATNAME COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV, * SUMX, SUMY, SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2, * NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF, * KEYT, KEYRET, JCODE, SUMF2R, Y, X, XSIG, * ITP, E1, E2, KEYDX, KEYDS, * NITFO, NITFC, NITDUA, NITDIF, NITFFT, * KENDFO, KENDFC, KENDUA, KENDIF, KENDFF, * FITDUA(7), FITDIF(4), FITFFT(5), * BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF) CHARACTER CHIN2 *80 110 CALL KERINA (IATOMS, LIT, 1, LEND) IF (LEND .NE. 0) THEN NSET = -NSET RETURN ENDIF IF (LIT(1) .NE. 'ATOMS') GOTO 110 CHIN2 = CHIN BACKSPACE IATOMS CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT) NSET = NSET + 1 NATQ = NAT NATH = 0 N = 1 143 CONTINUE IF (ATNAME(N)(1:1).EQ.'H' .AND. IZAT(N).EQ.1) NATH = NATH + 1 IF (ATNAME(N)(1:1) .EQ. 'Q') THEN IF (N .EQ. NAT) GOTO 148 DO 146 N1 = N, NAT - 1 CALL KERNAB (ATXYZ(1,N1+1), ATXYZ(1,N1), 10) ATNAME(N1) = ATNAME(N1+1) 146 IZAT(N1) = IZAT(N1+1) 148 NAT = NAT - 1 N = N - 1 ENDIF N = N + 1 IF (N .LE. NAT) GOTO 143 IF (NAT.LT.NATQ) WRITE (LIS2, FMT= * '('' Nr of Q-atoms (= peaks) rejected:'', I3)') NATQ-NAT IF (NATH.NE.0) WRITE (LIS1, FMT= * '('' Number of H atoms included:'', I3)') NATH IF (NAT .LE. 0) CALL KERROR ('.... No atoms left!', 0, 'ATIN7') IF (NSET .GT. 1) CALL ATOMPR (LIS2, 2, ATXYZ, ATNAME, IZAT, NAT) IF (NSET .GT. 1) CALL ATOMOC (1, ATXYZ, ITAT, NAT) CHIN = CHIN2 CALL KERINB (LIT, 1) RETURN END SUBROUTINE FCALII (NSET) 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 EQUIVALENCE (LIS1, IFILE(7)), (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 /CRYSB/ SPGR, WAVEAT, CELATY(10) CHARACTER SPGR *16, WAVEAT *2, CELATY *2 COMMON /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) DIMENSION FITFO(3), FITFC(2), FITFC2(51) EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1)) PARAMETER (MAXAT = 993) PARAMETER (MAXBUF = 198) COMMON / / SICO(12500), FF(500,10), EXPBP(500), EXPBR(500), * SUMF2(500), SUMF2P(500), SFAC(13,10), * ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT, * BUFFO(MAXBUF), BUFFC(MAXBUF), BUFBUF(MAXBUF), * KLAD(MAXAT) DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) COMMON /ATNAMA/ ATNAME(MAXAT) CHARACTER * 6 ATNAME COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV, * SUMX, SUMY, SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2, * NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF, * KEYT, KEYRET, JCODE, SUMF2R, Y, X, XSIG, * ITP, E1, E2, KEYDX, KEYDS, * NITFO, NITFC, NITDUA, NITDIF, NITFFT, * KENDFO, KENDFC, KENDUA, KENDIF, KENDFF, * FITDUA(7), FITDIF(4), FITFFT(5), * BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF) DEEL=1. IF (NSET .EQ. 0) CALL ATOMOC (0, ATXYZ, KLAD, NAT) CALL KERNZA (0.0, CELPAR, NTYPE) DO 170 I = 1,NAT DO 170 J = 1,NTYPE IF (IZAT(I) .NE. IZTYPE(J)) GOTO 170 ITAT(I) = J IF (NSET .EQ. 0) DEEL=KLAD(I) CELPAR(J) = CELPAR(J) + ATXYZ(4,I) * AMULT / DEEL 170 CONTINUE SUMZP = 0.0 SUMZA = 0.0 DO 180 I = 1,NTYPE SUMZP = SUMZP + CELPAR(I) * FF(2,I) ** 2 180 SUMZA = SUMZA + CELALL(I) * FF(2,I) ** 2 PSQ = SUMZP / SUMZA P1SQ = PSQ / ( ICENT * NSYMM ) IF (KEYD .GE. 5 .AND. KEYD .NE. 7) * WRITE(LIS1,FMT='('' $$$ Atom set'', I3, '' Nr of atoms:'', * I3, '' Scatt.fr. p**2 '', F6.3)') NSET, NAT, PSQ BPAV = 0. IF (KEYT .GT. 1) THEN IZATT = 0 DO 174 I = 1, NAT BPAV = BPAV + ATXYZ(5,I) * IZAT(I) **2 174 IZATT = IZATT + IZAT(I) ** 2 BPAV = BPAV / FLOAT(IZATT) IF (NSET .EQ. 1) WRITE (LIS2, 173) BPAV 173 FORMAT (' Averaged value of temp.factors for known atoms:', * ' Bp = ', F8.3) ENDIF IF (PSQ .GT. 1.1) THEN WRITE (CHOUT, FMT='('' Warning: P**2:'', F7.3)') PSQ IF (PSQ .LT. 1.20) THEN CALL SHOUT2 ELSE CALL SHOUT ENDIF ENDIF IF (PSQ .GT. 1.00) PSQ = 1.00 IF (NSET.EQ.1 .AND. KEYT.EQ.1) RETURN IF (KEYT .GE. 2) BP = 0.0 BPX = BP IF (NSET.GT.0 .AND. KEYT.GT.1) BPX = BPAV ISMAX = IFIX (STLMAX * 400. + 0.0001) + 2 IF (ISMAX .GT. 500) CALL KERROR ('STLMAX reset?', 270, 'FCALII') DO 282 IS=1,ISMAX STL = FLOAT(IS-1) * 0.0025 STL2 = STL * STL SUMF2P(IS) = 0.0 DO 260 I=1,NTYPE 260 SUMF2P(IS) = SUMF2P(IS)+ FF(IS,I) * FF(IS,I) * CELPAR(I) IF (NSET .EQ. 0) EXPBR(IS) = EXP(-BR * STL2) 282 EXPBP(IS) = EXP(-BPX * STL2) RETURN END SUBROUTINE FCALC (NSET) 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 EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IBINFO, IFILE(11)), (IBINFC, IFILE(12)) EQUIVALENCE (KEYWIL, KEYS(12)) LOGICAL SWRECY, EXPAND EQUIVALENCE (SWRECY, SWITCH(17)), (EXPAND, SWITCH(23)) LOGICAL LTESTR EQUIVALENCE (LTESTR, SWITCH(27)) 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 /CRYSB/ SPGR, WAVEAT, CELATY(10) CHARACTER SPGR *16, WAVEAT *2, CELATY *2 COMMON /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) DIMENSION FITFO(3), FITFC(2), FITFC2(51) EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1)) PARAMETER (MAXAT = 993) PARAMETER (MAXBUF = 198) COMMON / / SICO(12500), FF(500,10), EXPBP(500), EXPBR(500), * SUMF2(500), SUMF2P(500), SFAC(13,10), * ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT, * BUFFO(MAXBUF), BUFFC(MAXBUF), BUFBUF(MAXBUF) DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) EQUIVALENCE (R2X, BUFFFT(30)) COMMON /ATNAMA/ ATNAME(MAXAT) CHARACTER * 6 ATNAME COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV, * SUMX, SUMY, SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2, * NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF, * KEYT, KEYRET, JCODE, SUMF2R, Y, X, XSIG, * ITP, E1, E2, KEYDX, KEYDS, * NITFO, NITFC, NITDUA, NITDIF, NITFFT, * KENDFO, KENDFC, KENDUA, KENDIF, KENDFF, * FITDUA(7), FITDIF(4), FITFFT(5), * BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF) LOGICAL LBINFC, LCALR2 LBINFC = .TRUE. LTESTR = .TRUE. LCALR2 = .FALSE. IF (KEYD .LT. 5) LTESTR = .FALSE. IF (KEYD .EQ. 0 .AND. KEYDS .EQ. -1) LCALR2 = .TRUE. IF (LCALR2) LTESTR = .TRUE. IF (LCALR2) KEYWIL = 4 IF (LTESTR) LBINFC = .FALSE. IF (LBINFC) LTESTR = .FALSE. LIS1X=LIS1 IF (LTESTR) LIS1X=LIS2 R2MIN = 999. WRITE (LIS1, FMT='('' Calculate structure factors'')') IF (.NOT. LCALR2) * WRITE (LIS2, FMT='('' Calculate structure factors, new'', * '' temperature factors and new scale factor'')') FICENT = FLOAT (ICENT) IF (KEYD .GE. 5) THEN WRITE (LIS1, FMT='('' DDMAIN input OPTION :'', I2)') KEYD ENDIF GOTO 151 100 CALL ATIN7 (NSET) IF (NSET .LE. 0) GOTO 910 IF (KEYT .EQ. 3) CALL KERROR * (' No anisotr. allowed in AUTOR2 TEST runs', 100, 'AUTOFR') CALL FCALII (NSET) 151 CONTINUE IF (EXPAND) THEN WRITE (LIS1, 183) P1SQ WRITE (LIS2, 183) P1SQ 183 FORMAT (' Scattering fraction of known part:'/ * ' excluding symmetry related molecules: P1**2 =', F6.3) ELSE IF (PSQ .LT. 0.99) THEN WRITE (LIS2, 184) PSQ 184 FORMAT (' Scattering fraction of known part: P**2 =', F6.3) ENDIF ENDIF IF (.NOT. EXPAND) THEN NITFC = 2 IF (LBINFC) * CALL BINOFF (27, IBINFC,'BINFC', FITFC, NITFC, BUFFC, KENDFC) ELSE NITFC = 3 + 2 * NSYMM CALL BINOFF (27, IBINFC,'BINFC2', FITFC2, NITFC, BUFFC, KENDFC) ENDIF CALL RINI (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF, * RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2,ICENT) NREFL = 0 IREFL = 0 SUMNR2 = 0. SUMFO2 = 0. SUMFP2 = 0. SUMFF2 = 0. SUMFC2 = 0. SUMFO4 = 0. SUMFR4 = 0. CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO) NITFO = 3 200 CALL BINIFF (0, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO) IF (KENDFO.LT.0) GOTO 220 IREFL = IREFL + 1 CALL HKLC1U (HCODE, HKLX) CALL HKLSTL (HKLX, STL, STL2) IF (STL.GT.STLMAX .OR. HKLX(1,1).GT.HKLMAX(1) .OR. * HKLX(2,1).GT.HKLMAX(2) .OR. HKLX(3,1).GT.HKLMAX(3)) THEN FITFC(1) = -999. FITFC2(1) = -999. GOTO 215 ENDIF IF (.NOT. EXPAND) THEN CALL FCALC1 (KEYT, ATXYZ, ITAT, NAT) FP2F2R = FP**2 + (SUMF2(ISS) - SUMF2P(ISS)) * EXPBR(ISS)**2 SUMFO2 = SUMFO2 + FOBS**2 SUMFP2 = SUMFP2 + FP2F2R SUMFC2 = SUMFC2 + FP**2 FOSC = FOBS * SCALE SUMFR4 = SUMFR4 + (FP**2 - FOSC**2)**2 SUMFO4 = SUMFO4 + FOSC**4 CALL R2CALC (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF, * RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2) R2X = RNM2XZ IF (KEYWIL.NE.4) CALL WILSIN (KEYWIL) ELSE CALL FCALC2 (KEYT, ATXYZ, ITAT, NAT) SUMNR2 = SUMNR2 + ASYMM / EPSIL2 SF2 = SUMF2 (ISS) SF2P= SUMF2P(ISS) SUMFF2 = SUMFF2 + (SF2 - SF2P*ASYMC) * EXPBR(ISS) / EPSIL2 SUMFO2 = SUMFO2 + FOBS**2 / EPSIL2 DO 210 I = 1, NSYMM IF (FPEXP(1,I).GT.0.0) SUMFP2 = SUMFP2 + FPEXP(1,I)**2 210 CONTINUE ENDIF NREFL = NREFL + 1 215 IF (.NOT. EXPAND) THEN IF (LBINFC) * CALL BINOFF (0, IBINFC, 'BINFC', FITFC, NITFC, BUFFC, KENDFC) ELSE CALL BINOFF (0, IBINFC, 'BINFC2',FITFC2, NITFC, BUFFC, KENDFC) ENDIF GOTO 200 220 CONTINUE IF (.NOT. EXPAND) THEN IF (LBINFC) * CALL BINOFF (-1, IBINFC, 'BINFC', FITFC, NITFC, BUFFC, KENDFC) ELSE CALL BINOFF (-1, IBINFC, 'BINFC2',FITFC2, NITFC, BUFFC, KENDFC) ENDIF WRITE (LIS2, 240) IREFL 240 FORMAT (' Number of reflections read from file BINFO:', I5) IF (IREFL.NE.NREFL) WRITE (LIS2, 242) NREFL 242 FORMAT (' Note:', I6,' Reflections written to file BINFC(2) ') IF (.NOT. EXPAND) THEN CALL RPR (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF, * RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,PSQ) R2X = RNM2XZ SC98 = SQRT (SUMFC2 / SUMFO2) R2FFFF = SUMFR4 / SUMFO4 WRITE (LIS2, 249) SCALE, SC98, R2FFFF 249 FORMAT (' $TE SCALE, NEW SC ? , R2(F2):', 2F8.4, F6.3) IF (LCALR2) GOTO 990 IF (LTESTR) THEN IF (NSET .EQ. 1) THEN CHOUT = ' Structure factor calculation for all atom sets:' CALL SHOUT CHOUT = ' Set No. Nr.atoms p**2 expected R2 actual R2' CALL SHOUT ENDIF WRITE (CHOUT, 1254) NSET, NAT, PSQ, RNM2EZ, RNM2XZ 1254 FORMAT (I7, I8, F9.3, F13.3, F11.3) CALL SHOUT IF (RNM2XZ .LT. R2MIN) THEN R2MIN = RNM2XZ NSETM = NSET ENDIF ENDIF ELSE WRITE (LIS2, 254) NINT(SUMNR2) 254 FORMAT (' Number of reflections after expansion:', I10) SUMFP2 = SUMFP2 * FICENT + SUMFF2 ENDIF IF (LTESTR) GOTO 100 GOTO 990 910 CONTINUE CHOUT = ' Structure factor calc finished for all atom sets ' CALL SHOUT2 IF (R2MIN .LT. 998. .AND. NSETM .NE. 1) THEN WRITE (IPR1, 1255) R2MIN, NSETM WRITE (LIS1, 1255) R2MIN, NSETM 1255 FORMAT(' Note: Lowest value of R2 =', F6.3, ' for set nr.', I3) ENDIF 990 RETURN END SUBROUTINE FCALC1 (KEYT, ATXYZ, ITAT, NAT) DIMENSION ATXYZ(10,NAT), ITAT(NAT) 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 /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 /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) COMMON / / SICO(12500), FF(500,10), EXPBP(500), EXPBR(500), * SUMF2(500), SUMF2P(500), SFAC(13,10) DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) DIMENSION FFF(10), ADTRIG(24) DATA FFF, ADTRIG / 34*0.0 / S = STL * 400. + 1. IS = IFIX(S) STLDEL = S - FLOAT(IS) ISS = NINT(S) DO 110 J=1,NTYPE IF (CELPAR(J).LE.0.0) GOTO 110 FFF(J) = FF(IS,J) + (FF(IS+1,J)-FF(IS,J)) * STLDEL 110 CONTINUE CALL HKLEX1 (HKLX, HKLX) IF (NSYMM.EQ.1) GOTO 150 DO 140 J=2,NSYMM IF (ITRS(J).EQ.0) GOTO 140 ADTRIG(J) = HKLX(1,1)*TSYMM(1,J) + HKLX(2,1)*TSYMM(2,J) + * HKLX(3,1)*TSYMM(3,J) 140 CONTINUE 150 FAP = 0.0 FBP = 0.0 IF (KEYT.EQ.1) GOTO 300 DO 250 I=1,NAT A1 = 0. B1 = 0. A2 = 0. B2 = 0. DO 200 J=1,NSYMM TRIG = HKLX(1,J)*ATXYZ(1,I) + HKLX(2,J)*ATXYZ(2,I) + * HKLX(3,J)*ATXYZ(3,I) + ADTRIG(J) IF (TRIG.LT.0.0) TRIG = TRIG - 0.00010 ITRIG = MOD ( IFIX(TRIG * 10000. + 0.5), 10000) IF (ITRIG.LE.0) ITRIG = ITRIG + 10000 IF (ATXYZ(6,I) .GT. 0.0) GOTO 180 A1 = A1 + SICO(ITRIG + 2500) B1 = B1 + SICO(ITRIG + 2500) IF (ICENT.EQ.2) GOTO 200 A2 = A2 - SICO(ITRIG) B2 = B2 + SICO(ITRIG) GOTO 200 180 X1 = HKLX(1,J) * ATXYZ (5,I) * + HKLX(2,J) * ATXYZ(10,I) * + HKLX(3,J) * ATXYZ (9,I) X2 = HKLX(2,J) * ATXYZ (6,I) * + HKLX(3,J) * ATXYZ (8,I) X3 = HKLX(3,J) * ATXYZ (7,I) TF = EXP(-0.25 * ( X1*HKLX(1,J) + X2*HKLX(2,J) + X3*HKLX(3,J) )) A1 = A1 + SICO(ITRIG + 2500) * TF B1 = B1 + SICO(ITRIG + 2500) * TF IF (ICENT.EQ.2) GOTO 200 A2 = A2 - SICO(ITRIG) * TF B2 = B2 + SICO(ITRIG) * TF 200 CONTINUE IJ = ITAT(I) IF (ATXYZ(6,I).LT.0.0) THEN TF = ATXYZ(4,I) * EXP (-STL2 * ATXYZ(5,I)) ELSE TF = ATXYZ(4,I) ENDIF FAP = FAP + A1 * FFF(IJ) * TF FBP = FBP + B1 * SFAC(11,IJ) * TF IF (ICENT .EQ. 2) GOTO 250 FAP = FAP + A2 * SFAC(11,IJ) * TF FBP = FBP + B2 * FFF(IJ) * TF 250 CONTINUE FP = ASYMCL * SQRT (FAP*FAP + FBP*FBP) GOTO 500 300 DO 450 I=1,NAT A1 = 0. B2 = 0. DO 400 J=1,NSYMM TRIG = HKLX(1,J)*ATXYZ(1,I) + HKLX(2,J)*ATXYZ(2,I) + * HKLX(3,J)*ATXYZ(3,I) + ADTRIG(J) IF (TRIG.LT.0.0) TRIG = TRIG - 0.00010 ITRIG = MOD ( IFIX(TRIG * 10000. + 0.5), 10000) IF (ITRIG.LE.0) ITRIG = ITRIG + 10000 A1 = A1 + SICO(ITRIG + 2500) IF (ICENT.EQ.2) GOTO 400 B2 = B2 + SICO(ITRIG) 400 CONTINUE IJ = ITAT(I) FAP = FAP + A1 * FFF(IJ) * ATXYZ(4,I) IF (ICENT .EQ. 2) GOTO 450 FBP = FBP + B2 * FFF(IJ) * ATXYZ(4,I) 450 CONTINUE FP = ASYMCL * SQRT (FAP*FAP + FBP*FBP) * EXPBP(ISS) 500 PHIP = 0.0 IF (FP.GT.0.001) PHIP = ATAN2(FBP,FAP) / 0.0174532925 IF (PHIP.LT.0.0) PHIP = PHIP + 360. RETURN END SUBROUTINE FCALC2 (KEYT, ATXYZ, ITAT, NAT) DIMENSION ATXYZ(10,NAT), ITAT(NAT) 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 /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 /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) COMMON / / SICO(12500), FF(500,10), EXPBP(500), EXPBR(500), * SUMF2(500), SUMF2P(500), SFAC(13,10) DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) DIMENSION FFF(10) S = STL * 400. + 1. IS = IFIX(S) STLDEL = S - FLOAT(IS) ISS = NINT(S) DO 110 J=1,NTYPE IF (CELPAR(J).LE.0.0) GOTO 110 FFF(J) = FF(IS,J) + (FF(IS+1,J)-FF(IS,J)) * STLDEL 110 CONTINUE CALL HKLEX1 (HKLX, HKLX) CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2) EPSIL = IEPS EPSIL2 = IEPS2 DO 600 J=1,NSYMM IF (IDHKL(J).EQ.0) GOTO 200 K = IABS(IDHKL(J)) FPEXP(1,J) = -K FPEXP(2,J) = FPEXP(2,K) IF (FPEXP(2,J).LT.0.0001) FPEXP(2,J)=0.0001 IF (IDHKL(J).LT.0) FPEXP(2,J)=-FPEXP(2,J) GOTO 600 200 FAP = 0.0 FBP = 0.0 DO 400 I=1,NAT TRIG = HKLX(1,J)*ATXYZ(1,I) + HKLX(2,J)*ATXYZ(2,I) + * HKLX(3,J)*ATXYZ(3,I) IF (TRIG.LT.0.0) TRIG = TRIG - 0.00010 ITRIG = MOD ( IFIX(TRIG * 10000. + 0.5), 10000) IF (ITRIG.LE.0) ITRIG = ITRIG + 10000 IJ = ITAT(I) FAP = FAP + SICO(ITRIG + 2500) * FFF(IJ) FBP = FBP + SICO(ITRIG) * FFF(IJ) 400 CONTINUE FP = ALATT * SQRT (FAP*FAP + FBP*FBP) * EXPBP(ISS) PHIP = 0.0 IF (FP.GT.0.001) PHIP = ATAN2(FBP,FAP) / 0.0174532925 IF (PHIP.LT.0.0) PHIP = PHIP + 360. FPEXP(1,J) = FP FPEXP(2,J) = PHIP 600 CONTINUE RETURN END SUBROUTINE SCALE7 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 EQUIVALENCE (IDDL, IFILE(1)), (LIS2, IFILE(8)) EQUIVALENCE (KEYWIL, KEYS(12)) LOGICAL SWRECY, EXPAND EQUIVALENCE (SWRECY, SWITCH(17)), (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 /CRYSB/ SPGR, WAVEAT, CELATY(10) CHARACTER SPGR *16, WAVEAT *2, CELATY *2 COMMON /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) PARAMETER (MAXBUF = 198) COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV, * SUMX, SUMY, SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2, * NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF, * KEYT, KEYRET, JCODE, SUMF2R, Y, X, XSIG, * ITP, E1, E2, KEYDX, KEYDS, * NITFO, NITFC, NITDUA, NITDIF, NITFFT, * KENDFO, KENDFC, KENDUA, KENDIF, KENDFF, * FITDUA(7), FITDIF(4), FITFFT(5), * BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF) PARAMETER (PSQMAX = 0.90) WRITE (LIS2, FMT='('' Calculate new SCALE and B values'')') SC2 = SQRT (SUMFP2 / SUMFO2) WRITE (LIS2, 258) SC2 258 FORMAT (' New scale = SQRT((SUMFP2 + FF2R) / SUMFO2):', F11.5) IF (PSQ .LT. PSQMAX) THEN WRITE (LIS2, FMT='(''+'', 56X, ''(not used)'')') ELSE WRITE (LIS2, FMT='(''+'', 56X, '' accepted!'')') SCALE = SC2 KEYWIL = 4 ENDIF IF (KEYWIL .NE. 4) CALL WILPAR (IWILP) IWILP = 1 IF (KEYWIL.NE.4 .AND. KEYWIL.GE.0) * CALL WIL2DI (NREFL, IWILP) IF (KEYT .GE. 2) BP = BPAV WRITE (CHOUT, 362) SCALE, BP, BR 362 FORMAT ('SCALE ', F14.7, ' BP ', F11.5, ' BR ', F10.5) CALL LOGWR (IDDL) IF (KEYT .GE. 2) BP = 0.0 CALL FILCLO (IDDL, 'KEEP') RETURN END SUBROUTINE AUTOFR (NATS, NATL, NRECY, NSET) 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 EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (ICOND, IFILE(4)), (IDDL, IFILE(1)), (IDDS, IFILE(2)) EQUIVALENCE (I1,IFILE(9)), (IBINFO,IFILE(11)),(IBINFC, IFILE(12)) EQUIVALENCE (KEYWIL, KEYS(12)) LOGICAL SWRECY, NORECY, LSC98, NIJM EQUIVALENCE (SWRECY, SWITCH(17)), (NORECY, SWITCH(18)) EQUIVALENCE (LSC98, SWITCH(19)) LOGICAL LTESTR EQUIVALENCE (NIJM, SWITCH(1)), (LTESTR, SWITCH(27)) 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 /CRYSB/ SPGR, WAVEAT, CELATY(10) CHARACTER SPGR *16, WAVEAT *2, CELATY *2 COMMON /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) DIMENSION FITFO(3), FITFC(2), FITFC2(51) EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1)) PARAMETER (MAXAT = 993) PARAMETER (MAXBUF = 198) COMMON / / SICO(12500), FF(500,10), EXPBP(500), EXPBR(500), * SUMF2(500), SUMF2P(500), SFAC(13,10), * ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT, * BUFFO(MAXBUF), BUFFC(MAXBUF), BUFBUF(MAXBUF) DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) COMMON /ATNAMA/ ATNAME(MAXAT) CHARACTER * 6 ATNAME COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV, * SUMX, SUMY, SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2, * NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF, * KEYT, KEYRET, JCODE, SUMF2R, Y, X, XSIG, * ITP, E1, E2, KEYDX, KEYDS, * NITFO, NITFC, NITDUA, NITDIF, NITFFT, * KENDFO, KENDFC, KENDUA, KENDIF, KENDFF, * FITDUA(7), FITDIF(4), FITFFT(5), * BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF) EQUIVALENCE (R2X, BUFFFT(30)) CHARACTER*1 GWX CHARACTER*8 DDC CHARACTER*72 DDX DIMENSION FI2(30) DOUBLEPRECISION ATFP4(MAXAT), ATFPO(MAXAT), SFPS2, SFPS4, TERM2, * TERM3, RNUM2C, RDEN2C DOUBLEPRECISION ATTOT(MAXAT) LOGICAL LBINFC LBINFC = .TRUE. LTESTR = .TRUE. R2MIN = 999.9 DDC = 'DDL' FI1 = 17.* VOLUM NSETM = 0 IF (KEYD .LT.5) LTESTR = .FALSE. IF (LTESTR) LBINFC = .FALSE. IF (LBINFC) LTESTR = .FALSE. LIS1X=LIS1 IF (LTESTR) LIS1X=LIS2 NATNOW = 0 NATEND = 0 DO 103 IT = 1, NTYPE IF (IZTYPE(IT).NE.1) THEN NATEND = NATEND + CELALL(IT) NATNOW = NATNOW + CELPAR(IT) ENDIF 103 CONTINUE NATEND = NATEND / IMULT NATNOW = NATNOW / IMULT NATRES = NATEND - NATNOW NATREX = NATEND - NAT IF (.NOT. LTESTR) THEN WRITE(LIS1,*) * 'Number of original input atoms (minus removed ones) =',NATS WRITE(LIS1,*) * 'Number of atoms fed into the last Fourier synthesis =',NATL WRITE(LIS1,*) * 'Number of atoms (peaks) taken from last Fourier map =',NAT IF (NIJM) WRITE(LIS1,*) * ' NIJM: atoms (peaks) missing at this very moment =',NATRES IF (NIJM .AND. NATRES.NE.NATREX) WRITE(LIS1,*) * ' NIJM: WARNING: H-atoms? input non-H atoms counted: =',NATNOW IF (NATEND .NE. NAT) WRITE(LIS1,*) * 'Number of atoms expected in the complete structure =',NATEND ENDIF CRTEST = 0.0 NATFIX = 0 NDELM = NAT / 2 I6 = NATEND / 6 NDELM = MIN0 (NDELM, NAT - I6) IF (NATL .LT. NATS) NATL = NATS ICYCL = NRECY / 10 + 1 NRECYS = MOD (NRECY, 10) IF (ICYCL .LE. 3 .AND. NATS .LE. 3) NATFIX = NATS IF (ICYCL .LT. 2) GOTO 105 IF( ICYCL .LE. 2 ) THEN NDELM = MAX(0, 1 + ( NAT - NATL ) / 2 ) ELSE NDELM = MAX(0, 1 + 2 * ( NAT - NATL ) / 3 ) ENDIF IF (NDELM .LE.2 .AND. ICYCL.LE.4) NDELM = NAT - NATL IF (ICYCL .EQ. 5) NDELM = NAT / 4 IF (ICYCL .EQ. 7) NDELM = MAX0 (NAT / 5, NDELM) IF (NRECYS .GE. 8) NDELM = 0 105 CONTINUE ISTART = MAX ( NATFIX + 1, NAT - 500) ISTORE = MAX ( 2, ISTART ) ISTORM = ISTORE - 1 FICENT = FLOAT (ICENT) GOTO 113 109 CALL ATIN7 (NSET) IF (NSET .LE. 0) GOTO 910 IF (LTESTR) WRITE (LIS2, FMT='('' Atom Set Nr.'', I3)') NSET IF (KEYT .EQ. 3) CALL KERROR * (' No anisotr. allowed in AUTOR2 TEST runs', 100, 'AUTOFR') CALL FCALII (NSET) 113 CONTINUE IF (LTESTR) NDELM = 1 CALL KERNAB (BUFFC, BUFBUF, 27) NITFC = 2 IF (LBINFC) * CALL BINOFF (27, IBINFC,'BINFC', FITFC, NITFC, BUFFC, KENDFC) CALL RINI(RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF, * RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2,ICENT) DO 117 J = 1, MAXAT ATTOT(J) = 0.0 ATFP4(J) = 0.0 117 ATFPO(J) = 0.0 NREFL = 0 IREFL = 0 SUMNR2 =0. SUMFO2 = 0. SUMFP2 = 0. SUMFF2 = 0. RNUM2C = 0. RDEN2C = 0. TERM2 = 0. TERM3 = 0. SUMFC2 = 0. SUMFO4 = 0. SUMFR4 = 0. SFPS2 = 0. SFPS4 = 0. SUME2 = 0. SUME1 = 0. CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO) NITFO = 3 IF (ICYCL .NE. 3) GOTO 200 CALL XHELP (I1, LIS1, 411. ) READ (I1, 137, END=7112) READ (I1, 137, END=7112) FI2 137 FORMAT (3(10F7.1/)) 200 CALL BINIFF (0, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO) IF (KENDFO.LT.0) GOTO 220 IREFL = IREFL + 1 CALL HKLC1U (HCODE, HKLX) CALL HKLSTL (HKLX, STL, STL2) IF (STL.GT.STLMAX .OR. HKLX(1,1).GT.HKLMAX(1) .OR. * HKLX(2,1).GT.HKLMAX(2) .OR. HKLX(3,1).GT.HKLMAX(3)) THEN FITFC(1) = -999. FITFC2(1) = -999. GOTO 215 ENDIF CALL FCALC7 (KEYT, ATXYZ, ITAT, NAT, ETAO2) FP2F2R = FP**2 + (SUMF2(ISS) - SUMF2P(ISS)) * EXPBR(ISS)**2 SUMFO2 = SUMFO2 + FOBS**2 SUMFP2 = SUMFP2 + FP2F2R SUMFC2 = SUMFC2 + FP**2 FOSC = FOBS * SCALE SUMFR4 = SUMFR4 + (FP**2 - FOSC**2)**2 SUMFO4 = SUMFO4 + FOSC**4 NREFL = NREFL + 1 CALL R2CALC (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF, * RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2) R2X = RNM2XZ IF (KEYWIL.NE.4) CALL WILSIN (KEYWIL) FOSC = FOBS * SCALE EOBS2 = ( FOSC * FOSC ) / ETAO2 SUME2 = SUME2 + EOBS2 SUME1 = SUME1 + ABS(EOBS2 - 1.) FPS2 = ( FP * FP ) / ETAO2 IF (FPS2 .LT. 0.000001) FPS2 = 0.000001 FPS4 = FPS2 * FPS2 SFPS2 = SFPS2 + FPS2 SFPS4 = SFPS4 + FPS4 FAPM = FAP FBPM = FBP DO 205 I= 1, ISTORM FAPM = FAPM - ATXYZ(8,I) FBPM = FBPM - ATXYZ(9,I) 205 CONTINUE FPM = ASYMCL * SQRT(FAPM*FAPM+FBPM*FBPM) FPS2M = ( FPM * FPM ) / ETAO2 IF (FPS2M .LT. 0.000001) FPS2M = 0.000001 FPS4M = FPS2M * FPS2M ATFP4(ISTORM)=ATFP4(ISTORM) + FPS4M ATFPO(ISTORM)=ATFPO(ISTORM) - 2 * EOBS2 * FPS2M ATTOT(ISTORM)=ATTOT(ISTORM) + FPS4M - 2 * EOBS2 * FPS2M DO 210 I= ISTORE, NAT FAPM = FAP - ATXYZ(8,I) FBPM = FBP - ATXYZ(9,I) FPM = ASYMCL * SQRT(FAPM*FAPM+FBPM*FBPM) FPS2M = ( FPM * FPM ) / ETAO2 IF (FPS2M .LT. 0.000001) FPS2M = 0.000001 FPS4M = FPS2M * FPS2M ATFP4(I)=ATFP4(I) + FPS4M ATFPO(I)=ATFPO(I) - 2 * EOBS2 * FPS2M ATTOT(I)=ATTOT(I) + FPS4M - 2 * EOBS2 * FPS2M 210 CONTINUE TERM2 = TERM2 + FPS4 TERM3 = TERM3 - 2 * EOBS2 * FPS2 RNUM2C = RNUM2C + FPS4 - 2 * EOBS2 * FPS2 RDEN2C = RDEN2C + EOBS2 * EOBS2 215 CONTINUE IF (LBINFC) * CALL BINOFF (0, IBINFC, 'BINFC', FITFC, NITFC, BUFFC, KENDFC) GOTO 200 220 CONTINUE IF (LBINFC) * CALL BINOFF (-1, IBINFC, 'BINFC', FITFC, NITFC, BUFFC, KENDFC) IF (NSET .EQ. 1) WRITE (LIS2, 240) IREFL 240 FORMAT (' Number of reflections read from file BINFO:', I5) IF (IREFL.NE.NREFL .AND. NSET.EQ. 1) WRITE (LIS2, 242) NREFL 242 FORMAT (' Note:', I6,' reflections accepted ') SUME2 = SUME2 / FLOAT(NREFL) SUME1 = SUME1 / FLOAT(NREFL) SUME1X= 0.986 IF (ICENT .EQ. 1) SUME1X= 0.736 WRITE (LIS1X, 1242) SUME2, SUME1, SUME1X 1242 FORMAT (' Statistics: =', F6.3, ' <|E2-1|> =', F6.3/ * ' Expected : = 1.000 <|E2-1|> =', F6.3) IF (SUME1 .LT. 0.65) WRITE (LIS1X, 1243) 1243 FORMAT (' Beware of possible twinning !!!!!!!!!!!!!!!!!'/) CALL RPR (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF, * RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,PSQ) R2X = RNM2XZ DDC(4:8) = 'IC ' SC98 = SQRT (SUMFC2 / SUMFO2) R2FFFF = SUMFR4 / SUMFO4 XXX6 = 100. * ABS ( (1. - SCALE / SC98) ) IF (XXX6 .GT. 1.00) THEN WRITE (LIS2, 249) SCALE, SC98, R2FFFF 249 FORMAT (' $TE SCALE, New SCALE ? , R2(F2):', 2F8.4, F6.3) IF (NRECYS .GE. 6) WRITE (LIS2, * FMT='('' $TE SCALE, new scale ignored ... '')') ENDIF IF (ICYCL .LT.4 .OR. R2X .GT. 0.30 .OR. NRECYS .GE. 6) GOTO 250 XXX7 = 100. * FLOAT(NATEND - NATNOW) / FLOAT(NATEND) IF (ABS (XXX7) .GT. 20.) GOTO 250 LSC98 = .TRUE. SCALE = SC98 SUMFP2 = SUMFC2 IF (XXX6 .LE. 1.00) GOTO 250 WRITE (LIS2, FMT='('' $TE SCALE, New scale accepted ... '')') 250 CONTINUE IF (ICYCL .NE. 3) GOTO 7250 CALL FILINQ (ICOND, DDC, 'FORMATTED', 'INPUT', KINQ) IF (KINQ .NE. 0) THEN DDC(3:8) = 'CONFIG' CALL FILINQ (ICOND, DDC, 'FORMATTED', 'INPUT', KINQ) ENDIF IF (KINQ .NE. 0) GOTO 9111 DO 2111 I=1,199 READ (ICOND, FMT='(A72)', END=2112) DDX IF (DDX(1:9) .EQ. 'Licensee:') THEN III=0 DO 3111 II=10,72 CALL KERICH (111, DDX(II:II), K) 3111 III = III + K III = III * 17 GOTO 4111 ENDIF 2111 CONTINUE 2112 CALL KERNER ( 0, 'MAIN') 4111 READ (ICOND, FMT='(20X,I6, 1X, A1)', END=2112) IDDX, GWX READ (ICOND, FMT='(22X,I6)', END=2112) IDDX2 CALL FILCLO (ICOND, 'KEEP') IDDXX = III - IDDX IDDXX2 = IDDX2 / 37 IDDXX3 = IDDX2 - 37* IDDXX2 IF (IDDXX .NE. 0) THEN GOTO 7112 ENDIF IF (GWX .EQ. 'G' .AND. IDDXX3 .EQ. 0) GOTO 7250 IF (GWX .EQ. 'X' .AND. IDDXX3 .EQ. 2) GOTO 7250 IF (GWX .NE. 'W') GOTO 7112 IF (IDDXX3 .NE. 1) GOTO 7112 9111 CALL CONFI (0, KEND) IF (KEND .LT. 0) GOTO 7112 IF (KEND .EQ. 0) GOTO 5112 IF ( ABS(FI1-FI2(KEND)) .LT. 1.) GOTO 7250 IF (FI2(KEND) .LT. 0.) GOTO 7250 GOTO 7112 5112 CALL CONFI (877, KEND) CALL KESTOP CALL KEPROX RETURN 7112 CONTINUE CALL CONFI (777, KEND) CALL KESTOP CALL KEPROX RETURN 7250 IF( NDELM.EQ.0 ) GOTO 857 IF( NAT .EQ. 1 ) GOTO 857 TERM2 = TERM2 / RDEN2C EXPRC = 36. * FLOAT(IMULT) / SUMF2(2) AVCR = 0. NAVCR = 0 SDCR = 0. DO 251 IR = ISTORM, NAT ATXYZ(8,IR) = SFPS4 - ATFP4(IR) ATXYZ(8,IR) = ATXYZ(8,IR) / RDEN2C IF ((ATXYZ(8,IR)) .LT. 0.000001) ATXYZ(8,IR) = 0.000001 ATXYZ(9,IR) = TERM3 - ATFPO(IR) ATXYZ(9,IR) = ATXYZ(9,IR) / RDEN2C ATXYZ(10,IR) = ATXYZ(8,IR) + ATXYZ(9,IR) ATXYZ(10,IR) = RNUM2C - ATTOT(IR) ATXYZ(10,IR) = ATXYZ(10,IR) / RDEN2C CR = 10000. IF ((ATXYZ(8,IR)) .LT. 0.0000001) CALL KERROR * (' R2-TERM2 too low: impossible??', 244, 'AUTOFR') CR = ATXYZ(10,IR) * 36. / ( IZAT(IR)**2 * ATXYZ(4,IR) ) CR = CR / EXPRC ATXYZ(7,IR) = CR AVCR = AVCR + CR NAVCR= NAVCR + 1 251 CONTINUE IF ( NAVCR .LE. 0 ) THEN CHOUT= 'All atoms increase R2: wrong atom set?' NAVCR = 1 CALL SHOUT ENDIF AVCR = AVCR / FLOAT(NAVCR) DO 254 IR = ISTORM, NAT CR = ATXYZ(7,IR) IF ( IR.GT.ISTORM .OR. NATFIX.LE.1 ) THEN SDCR = SDCR + (AVCR - CR)**2 ENDIF 254 CONTINUE SDCR = SQRT ( SDCR / FLOAT(NAVCR) ) IF (.NOT. LTESTR) WRITE (LIS1, 1250) AVCR, SDCR, NAVCR WRITE (LIS2, 1250) AVCR, SDCR, NAVCR 1250 FORMAT (' Averaged relative contribution:', F6.3, * ' s.d.:', F6.3 , ' for ', I4, ' terms') AVSD2 = AVCR + 2. * SDCR IF ( PSQ.LT.0.95 .AND. ICYCL.LE.2 ) THEN CRTEST = AMIN1( 0.25, AVSD2) IF (AVCR.GT.0.0) CRTEST = AMIN1( 0.75, AVSD2) ELSE CRTEST = AMIN1 (0.5, AVSD2) IF (NATRES.LE.2) THEN IF (NAT.GT.100) THEN SDADD = 0. DO 257 IL = NAT-30,NAT SDADD = SDADD + SDCR * 0.04 ATXYZ(7,IL) = ATXYZ(7,IL) + SDADD 257 CONTINUE ENDIF ENDIF ENDIF AVSD1 = AVCR + SDCR BADR2 = R2X - RNM2EZ IF (R2X .GT. 0.2 .AND. BADR2 .GT. 0.09999) * AVSD1 = AVCR + SDCR * 0.1 / BADR2 CRTES1 = CRTEST IF (BADR2 .GT. 0.1) CRTES1 = AMIN1 (CRTEST, AVSD1) CRTEST = AMAX1( CRTEST, AVCR + 0.001) IF( CRTEST .LT. -0.5 ) CRTEST = -0.5 IF (PSQ .GT. 0.90) CRTEST = AMAX1 (CRTEST, 0.5 * PSQ) IF (.NOT. LTESTR) WRITE (LIS2, 259) CRTES1, CRTEST 259 FORMAT (' Acceptance criterion for R2-rejection =', F7.3, ' ???'/ * ' Acceptance criterion ( heavy atoms !) =', F7.3, ' ???'/ 1 ' Expected relative contribution to R2 = -1.000') NDELMC = 0 DO 263 IR = ISTORM, NAT CR = ATXYZ(7,IR) IF (LTESTR) THEN WRITE(LIS2,261) NSET, IR, * ATNAME(IR),ATXYZ(8,IR),ATXYZ(9,IR),ATXYZ(10,IR), CR 261 FORMAT(' Set', I3,' Atom', I3, 1X, A6, ' contr. to R2 =', F6.5, * F7.5, ' =', F7.5, ' Rel:', F7.3 ) ELSE IF ((CR .GT. CRTEST .AND. IZAT(IR) .GT. 13) .OR. * (CR .GT. CRTES1 .AND. IZAT(IR) .LE. 13)) THEN NDELMC = NDELMC + 1 IF (NDELM .EQ. 0) WRITE(LIS1,262) IR, ATNAME(IR), CR IF (NDELM .NE. 0) WRITE(LIS2,262) IR, ATNAME(IR), CR 262 FORMAT(' Atom', I3,1X, A6, ' Relative contribution to R2 =', F6.4) ENDIF ENDIF 263 CONTINUE IF( NAT .GE. 10 .AND. ICYCL .LE. 7 ) * NDELM = MAX0( NDELM, INT( FLOAT(NAT) *(RNM2XZ-RNM2EZ)/(PSQ*2.))) IF( NAT .GE. 20 .AND. ICYCL .LE. 7 .AND. PSQ .GT. 0.8) * NDELM = MAX0( NDELM, INT( FLOAT(NAT) *(RNM2XZ-RNM2EZ)/(PSQ))) NDELM = MIN0 (NDELM, NAT*2/3) IF (FLOAT(NDELM)/FLOAT(NAT).LT.0.01*FLOAT(ICYCL-3)) NDELM = 0 NDELM = MIN0 ( NDELM, NDELMC ) NDEL =0 IF (NORECY) THEN WRITE (LIS2, FMT='(A)') * ' No rejections if NORECY is given in automatic mode' GOTO 857 ENDIF IF (LTESTR) GOTO 857 IF( NDELM.EQ.0 ) GOTO 857 IZAV = 0 Z2TOT = 0. DO 267 I = 1, NAT Z2TOT = Z2TOT + FLOAT(IZAT(I))**2 267 IZAV = IZAV + IZAT(I) IZ2TOT = NINT (Z2TOT * 0.90) ZAV = FLOAT(IZAV) / FLOAT(NAT) DO 277 ID = 1, NDELM CRMAX = -100.0 IAD = 0 DO 273 IS = ISTART, NAT IF ( ATXYZ(8,IS). LT . 0.000001 ) GOTO 273 IF ( ATXYZ(7,IS) .GT. CRMAX) THEN CRMAXT = ATXYZ(7,IS) FZAF = SQRT (FLOAT(IZAT(IS)) / ZAV) IF (CRMAXT .GT. 0. .AND. FZAF .GT. 1.2) CRMAXT = CRMAXT / FZAF IF (CRMAXT .LT. CRMAX) GOTO 273 CRMAX = CRMAXT IAD = IS ENDIF 273 CONTINUE IF(IAD.EQ.0) GOTO 309 IZ2TOT = IZ2TOT - IZAT(IAD)**2 IF (IZ2TOT .LT. 0) GOTO 309 NDEL = NDEL + 1 WRITE (LIS1,275) IAD, ATNAME(IAD), CRMAX 275 FORMAT(' Atom', I4, ' = ' , A6, 1 ' is deleted! (Rel. contribution to R2 =', F7.4, ')') TERM2 = TERM2 - ATXYZ(8,IAD) TERM3 = TERM3 - ATXYZ(9,IAD) * RDEN2C ATXYZ(8,IAD) = 0.0 ATXYZ(9,IAD) = 0.0 ATXYZ(10,IAD) = -999. ISMAX = IFIX (STLMAX * 400. +0.0001) + 2 ITY = ITAT(IAD) DO 276 IS=1,ISMAX 276 SUMF2P(IS) = SUMF2P(IS) - FF(IS,ITY) * FF(IS,ITY) * ICENT * NSYMM PSQ = SUMF2P(2)/SUMF2(2) 277 CONTINUE 309 CONTINUE IF( NDEL.LE.0 ) GOTO 801 KEYS(1) = 99 WRITE (IPR1, 333) NDEL 333 FORMAT (' Nr of atoms deleted because of R2: ', I4) NATSN = 0 IF (NATFIX.EQ.0) THEN DO 388 IR = 1 ,NATS 388 IF (ATXYZ(10,IR).LT.-998.) NATSN = NATSN + 1 ENDIF NSC = NAT ISC = 1 390 IF (ATXYZ(10,ISC).LT.-998.) THEN NSC = NSC - 1 DO 395 IS2 = ISC, NSC ATNAME(IS2) = ATNAME(IS2 + 1) IZAT(IS2) = IZAT(IS2 + 1) ITAT(IS2) = ITAT(IS2 + 1) DO 392 NE = 1, 10 ATXYZ(NE,IS2) = ATXYZ(NE, IS2 + 1) 392 CONTINUE 395 CONTINUE ELSE ISC = ISC + 1 ENDIF IF ( ISC .LE. (NAT-NDEL) ) GOTO 390 NAT = NAT - NDEL IF (NATSN .GT. 0) THEN NATS = NATS - NATSN IF (ICYCL .GT. 1) THEN CHOUT = ' One or more original atoms skipped !! ' CALL SHOUT2 ENDIF CALL LOGRD(IDDL, 'NAT=', KLOG) IRUN = 0 IF (KLOG .GT. 0) IRUN = NINT(FNUM(2)) IF (IRUN .NE. KEYS(13)) GOTO 411 KPROG= NINT(FNUM(4)) WRITE (CHOUT,FMT='(''RUN '',I3,'' NEW NAT= '',I4, * '' KPROG '', I3)') IRUN, NATS, KPROG CALL LOGWR (IDDL) 411 CALL FILCLO (IDDL, 'KEEP') ENDIF CALL FCALII (NSET) DO 475 I = 1, NAT ATXYZ(8,I) = -0.000001 ATXYZ(9,I) = 0.0 ATXYZ(10,I) = 0.0 475 CONTINUE BUFBUF(25) = NAT BUFBUF(26) = P1SQ BUFBUF(27) = PSQ CALL KERNAB (BUFBUF, BUFFC, 27) CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO) CALL FCALC (NSET) IF (MOD(NRECY,10) .LT. 8) RETURN IF (ICYCL.LE.9) NRECY = NRECY - 1 KEYD = 3 CALL FILINQ (ICOND, 'CONDA', 'FORMATTED', 'OUTPUT', KINQ) CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ) WRITE (ICOND, * FMT = '(''CONDA '', A6, '' generated by AUTOFR'' )') CCODE IF (TITLE .NE. ' ') * WRITE (ICOND, FMT = '(''TITLE '', A64 )') TITLE WRITE (ICOND, FMT = '(''PROGRAM FOUR NRECY '', I3)') NRECY WRITE (ICOND, FMT = '(''PROGRAM NUTS AT2X'')') WRITE (ICOND, FMT = '(''FINISH'')') WRITE (IDDS, FMT = '(''FOUR'' / ''NUTS'' / ''STOP'')') CALL FILCLO (ICOND, 'KEEP') CALL FILCLO (IDDS, 'KEEP') RETURN 801 CONTINUE 857 CONTINUE IF (LTESTR) THEN IF (NSET .EQ. 1) THEN CHOUT = ' Structure factor calculation for all atom sets:' CALL SHOUT CHOUT = ' Set No. Nr.atoms p**2 expected R2 actual R2' CALL SHOUT ENDIF WRITE (CHOUT, 1254) NSET, NAT, PSQ, RNM2EZ, RNM2XZ 1254 FORMAT (I7, I8, F9.3, F13.3, F11.3) CALL SHOUT IF (RNM2XZ .LT. R2MIN) THEN R2MIN = RNM2XZ NSETM = NSET ENDIF GOTO 109 ENDIF CHOUT = ' AUTOFR finished: All input atoms accepted!' CALL SHOUT2 RETURN 910 CONTINUE CHOUT = ' AUTOFR finished for all atom sets ' CALL SHOUT2 IF (R2MIN .LT. 998. .AND. NSETM .NE. 1) THEN WRITE (IPR1, 1255) R2MIN, NSETM WRITE (LIS1, 1255) R2MIN, NSETM 1255 FORMAT(' Note: Lowest value of R2 =', F6.3, ' for set nr.', I3) ENDIF RETURN END SUBROUTINE FCALC7 (KEYT, ATXYZ, ITAT, NAT, ETAO2) DIMENSION ATXYZ(10,NAT), ITAT(NAT) 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 /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 /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) COMMON / / SICO(12500), FF(500,10), EXPBP(500), EXPBR(500), * SUMF2(500), SUMF2P(500), SFAC(13,10) DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) DIMENSION FFF(10), ADTRIG(24) DATA FFF, ADTRIG / 34*0.0 / S = STL * 400. + 1. IS = IFIX(S) STLDEL = S - FLOAT(IS) ISS = NINT(S) DO 110 J=1,NTYPE IF (CELPAR(J).LE.0.0) GOTO 110 FFF(J) = FF(IS,J) + (FF(IS+1,J)-FF(IS,J)) * STLDEL 110 CONTINUE TBPOV = EXPBP (ISS) CALL HKLEX1 (HKLX, HKLX) IF (NSYMM.EQ.1) GOTO 150 DO 140 J=2,NSYMM IF (ITRS(J).EQ.0) GOTO 140 ADTRIG(J) = HKLX(1,1)*TSYMM(1,J) + HKLX(2,1)*TSYMM(2,J) + * HKLX(3,1)*TSYMM(3,J) 140 CONTINUE 150 FAP = 0.0 FBP = 0.0 DO 250 I=1,NAT A1 = 0. B2 = 0. DO 200 J=1,NSYMM TRIG = HKLX(1,J)*ATXYZ(1,I) + HKLX(2,J)*ATXYZ(2,I) + * HKLX(3,J)*ATXYZ(3,I) + ADTRIG(J) IF (TRIG.LT.0.0) TRIG = TRIG - 0.00010 ITRIG = MOD ( IFIX(TRIG * 10000. + 0.5), 10000) IF (ITRIG.LE.0) ITRIG = ITRIG + 10000 A1 = A1 + SICO(ITRIG + 2500) IF (ICENT.NE.2) B2 = B2 + SICO(ITRIG) 200 CONTINUE IF (KEYT .EQ. 1) THEN TF = ATXYZ(4,I) * TBPOV ELSE TF = ATXYZ(4,I) * EXP (-STL2 * ATXYZ(5,I)) ENDIF IJ = ITAT(I) ATXYZ(8,I) = A1 * FFF(IJ) * TF FAP = FAP + ATXYZ(8,I) IF (ICENT.EQ.2) GOTO 250 ATXYZ(9,I) = B2 * FFF(IJ) * TF FBP = FBP + ATXYZ(9,I) 250 CONTINUE ETAO2 = SUMF2P(ISS) * ( EXPBP(ISS) * EXPBP(ISS) ) + * ( SUMF2(ISS) - SUMF2P(ISS) ) * ( EXPBR(ISS) * EXPBR(ISS) ) FP = ASYMCL * SQRT (FAP*FAP + FBP*FBP) PHIP = 0.0 IF (FP.GT.0.001) PHIP = ATAN2(FBP,FAP) / 0.0174532925 IF (PHIP.LT.0.0) PHIP = PHIP + 360. RETURN END SUBROUTINE RINI (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF, * RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2,ICENT) IF (ICENT.EQ.1) THEN C1 = 4 C2 = 2 ELSE C1 = 6 C2 = 3 ENDIF RNUM = 0. RDEN = 0. RNM2XF= 0. RDN2XF= 0. RNM2EF= 0. RDM2EF= 0. RNM2XZ= 0. RDN2XZ= 0. RNM2EZ= 0. RDN2EZ= 0. SR2NUM= 0. SR2DEN= 0. RETURN END SUBROUTINE R2CALC (RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF, * RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,C1,C2) 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 EQUIVALENCE (IBINFO, IFILE(11)), (IBINFC, IFILE(12)) EQUIVALENCE (KEYWIL, KEYS(12)) LOGICAL SWRECY, EXPAND EQUIVALENCE (SWRECY, SWITCH(17)), (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 /CRYSB/ SPGR, WAVEAT, CELATY(10) CHARACTER SPGR *16, WAVEAT *2, CELATY *2 COMMON /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) PARAMETER (MAXAT = 993) PARAMETER (MAXBUF = 198) COMMON / / SICO(12500), FF(500,10), EXPBP(500), EXPBR(500), * SUMF2(500), SUMF2P(500), SFAC(13,10), * ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT, * BUFFO(MAXBUF), BUFFC(MAXBUF), BUFBUF(MAXBUF) DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) COMMON /ATNAMA/ ATNAME(MAXAT) CHARACTER * 6 ATNAME COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV, * SUMX, SUMY, SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2, * NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF, * KEYT, KEYRET, JCODE, SUMF2R, Y, X, XSIG, * ITP, E1, E2, KEYDX, KEYDS, * NITFO, NITFC, NITDUA, NITDIF, NITFFT, * KENDFO, KENDFC, KENDUA, KENDIF, KENDFF, * FITDUA(7), FITDIF(4), FITFFT(5), * BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF) FOSC = FOBS * SCALE FDEL = ABS (FOSC-FP) RNUM = RNUM + FDEL RDEN = RDEN + FOSC ETAO2 = SUMF2P(ISS) * EXPBP(ISS)**2 + * (SUMF2(ISS) - SUMF2P(ISS)) * EXPBR(ISS)**2 ETAC2 = SUMF2P(ISS) * EXPBP(ISS)**2 ETA2 = ETAC2 / ETAO2 EOBS2 = FOSC **2 / ETAO2 EOBS = EOBS2 **0.5 EOBS4 = EOBS2 **2 ETAEP2 = FP**2 / ETAO2 EP = FP / ETAC2 **0.5 RNM2XF = RNM2XF + (EOBS2 - ETAEP2)**2 RDN2XF = RDN2XF + EOBS4 ETA8 = ETA2 **4 ETA4 = ETA2 **2 ETA2M4 = ETA2 - ETA4 RNM2EF = RNM2EF + EOBS4 * (ETA8 - 2*ETA4 + 1) + * EOBS2 * (C1 * ETA4 - 2) * ETA2M4 + * C2 * ETA2M4**2 RDN2EF = RDN2XF ETA2 = SUMF2P(2) / SUMF2(2) RNM2XZ = RNM2XZ + (EOBS2 - ETA2 * EP**2)**2 RDN2XZ = RDN2XZ + EOBS4 ETA8 = ETA2**4 ETA4 = ETA2**2 ETA2M4 = ETA2-ETA4 RNM2EZ = RNM2EZ + EOBS4 * (ETA8 - 2*ETA4 + 1) + * EOBS2 * (C1 * ETA4 - 2) * ETA2M4 + * C2 * ETA2M4**2 RDN2EZ = RDN2XF EOBS6 = EOBS2**3 ETA6 = ETA2**3 ETA8 = ETA4**2 ETA10 = ETA2**5 ETA12 = ETA4**3 ETA14 = ETA2**7 IF(ICENT.EQ.1) THEN SR2NUM = SR2NUM + * EOBS6 * ( 8 * ETA14 - 16 * ETA10 + 8 * ETA6 ) * * ( 1 - ETA2 ) + * EOBS4 * ( 52 * ETA12 - 48 * ETA8 + 4 * ETA4 ) * * ( 1 - ETA2 )**2 + * EOBS2 * ( 80 * ETA10 - 16 * ETA6 ) * * ( 1 - ETA2 )**3 + * 20 * ETA8 * ( 1 - ETA2 )**4 ELSE SR2NUM = SR2NUM + * EOBS6 * ( 16 * ETA14 - 32 * ETA10 + 16 * ETA6 ) * * ( 1 - ETA2 ) + * EOBS4 * ( 168 * ETA12 - 144 * ETA8 + 8 * ETA4 ) * * ( 1 - ETA2 )**2 + * EOBS2 * ( 384 * ETA10 - 48 * ETA6 ) * * ( 1 - ETA2 )**3 + * 96 * ETA8 * ( 1 - ETA2 )**4 ENDIF SR2DEN = SR2DEN + EOBS4 RETURN END SUBROUTINE RPR(RNUM,RDEN,RNM2XF,RDN2XF,RNM2EF,RDN2EF, * RNM2XZ,RDN2XZ,RNM2EZ,RDN2EZ,SR2NUM,SR2DEN,PSQ) 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 EQUIVALENCE (IDDL, IFILE(1)), (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IPR1, IFILE(6)) LOGICAL LTESTR EQUIVALENCE (LTESTR, SWITCH(27)) RNUM = RNUM / RDEN RNM2XF = RNM2XF / RDN2XF RNM2XZ = RNM2XZ / RDN2XZ RNM2EF = RNM2EF / RDN2EF RNM2EZ = RNM2EZ / RDN2EZ RNM2EF = RNM2EF**2 + (1.0 - RNM2EF) * SQRT(RNM2EF**2 + 0.01) RNM2EZ = RNM2EZ**2 + (1.0 - RNM2EZ) * SQRT(RNM2EZ**2 + 0.01) IF ( RNM2XZ .LT. 0.10 ) RNM2EZ = RNM2XZ IF ( SR2NUM .LT. 0.0 ) SR2NUM = 0.0 SR2NUM = SR2NUM**0.5 SR2NUM = SR2NUM / SR2DEN IF (LTESTR) RETURN IF(PSQ.GT..50) WRITE (LIS1, 251) RNUM 251 FORMAT (' Conventional R-factor =', F7.3) WRITE (LIS2, 250) RNM2XF,RNM2EF,RNM2XZ,RNM2EZ, RNM2XZ 250 FORMAT (' R2 (fj) =', F6.3, ' (est.:', F5.3, * ') R2 (Zj) =', F6.3, ' (est.:', F5.3, ') =====>', F6.3,/) IF ( RNM2XZ .GE. 0.10 ) THEN WRITE (LIS1, 255) RNM2EZ, RNM2XZ WRITE (IPR1, 255) RNM2EZ, RNM2XZ 255 FORMAT (31X, 'expected R2 :', F6.3, ' ==> actual R2 :', F6.3) ELSE WRITE (LIS1, 256) RNM2XZ WRITE (IPR1, 256) RNM2XZ 256 FORMAT (49X, ' ===> actual R2 :', F6.3) ENDIF RETURN END SUBROUTINE SCASTA 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 EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IBINFO, IFILE(11)), (IBINFC, IFILE(12)) EQUIVALENCE (IDDL, IFILE(1)), (KEYWIL, KEYS(12)) 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 /CRYSB/ SPGR, WAVEAT, CELATY(10) CHARACTER SPGR *16, WAVEAT *2, CELATY *2 COMMON /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) DIMENSION FITFO(3), FITFC(2), FITFC2(51) EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1)) PARAMETER (MAXAT = 993) PARAMETER (MAXBUF = 198) COMMON / / SICO(12500), FF(500,10), EXPBP(500), EXPBR(500), * SUMF2(500), SUMF2P(500), SFAC(13,10), * ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT, * BUFFO(MAXBUF), BUFFC(MAXBUF), BUFBUF(MAXBUF) DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV, * SUMX, SUMY, SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2, * NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF, * KEYT, KEYRET, JCODE, SUMF2R, Y, X, XSIG, * ITP, E1, E2, KEYDX, KEYDS, * NITFO, NITFC, NITDUA, NITDIF, NITFFT, * KENDFO, KENDFC, KENDUA, KENDIF, KENDFF, * FITDUA(7), FITDIF(4), FITFFT(5), * BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF) DIMENSION AVAL(100),BVAL(100),CVAL(200), * SCERR(21),IPGO(9,21,3),PGO1(9,21,3),PGO2(9,21,3),FPGOS(2,9,3), * FBEX(3),PGOS1(2,9,3),PGOS2(2,9,3),IREFST(2,9,3),SCTAB(2,9,3), * RSCTL(2,9,3),RSCNM(2,9,3),RSC(2,9,3),E2SUMT(2,9,3),BPVAR(10,3), * BRVAR(10,3),E2FOM(2,9,3) EQUIVALENCE (AVAL(1),CVAL(1)), (BVAL(1),CVAL(101)) LOGICAL SCOK1, SCOK2, WCHOSE PARAMETER (DELTAB = 0.05, DELTAS = 0.02, RAD = 57.29578) PARAMETER (BOVVAR = 0.2) DATA AVAL / * 0.05607, 0.05316, 0.10737, 0.43949, 0.38354, 0.94552, 0.78177, * 1.77778,-0.62897, 0.52696, 0.26794, 0.64104,-1.23707, 0.66410, * 0.17746, 0.48249,-0.40477,-0.20574, 1.01686,-1.02381,-0.49083, *-0.99899,-0.10605, 1.22243,-0.79348,-0.50365, 0.05771, 0.11873, *-0.38572,-0.48818, 0.51336,-1.72440, 0.29756, 0.62057,-1.10752, *-0.72877, 0.91284,-0.28598,-1.39700,-0.02802,-0.98413,-0.29812, * 0.14420,-0.03831, 0.77742,-0.97348, 0.24064, 0.88360,-0.00087, * 0.94690,-0.76506, 0.21406, 0.55916, 0.60612, 0.73216,-0.60812, *-0.68421, 0.26031,-0.51343,-0.56541,-0.59166, 0.13868, 1.21770, *-0.61774, 0.74481,-0.29790,-0.54401,-0.14904, 0.24532,-0.07146, *-1.18466,-0.11162, 0.01974, 0.40478,-0.11380, 0.18916,-0.65419, * 0.16521,-0.35749, 0.44576, 1.40299,-0.74702,-0.64231, 0.42047, * 0.10152,-0.42354,-0.98954,-0.03869,-0.02689,-0.32888,-0.49380, * 0.37292,-0.93195, 0.76896, 0.12626, 0.35347,-0.72071, 0.33275, *-0.34783, 0.03697 / DATA BVAL / *-0.03907,-1.75002,-0.06408, 1.12202,-0.24004,-0.66600,-0.11809, *-1.40804,-1.42002,-0.24606,-0.88801, 0.52319,-0.64014, 0.34116, * 0.29016,-0.28116,-0.14612, 0.24712, 0.47915,-0.28316,-0.48419, *-1.24918,-0.84426, 1.10029, 1.17727, 0.76122, 0.86424, 0.25520, * 0.52625,-0.99430, 0.06231,-0.58133, 0.29139, 1.01030,-0.79730, * 0.23834, 0.25831, 2.00439, 0.59242,-0.90149, 0.09043, 0.54341, * 0.45847, 0.93748,-0.03748,-0.07542, 0.47249, 0.61343,-0.26141, * 1.63743,-0.34850,-0.11253,-0.23654, 0.30458, 0.07050,-0.16750, *-1.13557,-0.26351, 0.87757,-0.58550, 0.24956,-0.64854, 0.24951, *-1.58359,-0.79956, 1.46555, 0.04664,-0.41467, 0.42766,-0.56565, *-0.86260,-0.74867, 0.30365, 0.22761, 0.68965,-0.06278, 0.70473, * 0.68972, 0.00874, 0.23871, 0.33476,-1.04381,-0.61488, 1.28188, * 1.22180, 1.09083,-0.28580,-0.59186,-1.14085, 0.73180, 0.87385, * 0.14382,-0.85487,-1.05181,-0.18495, 0.15194,-0.04698,-0.81092, *-0.98992, 0.16298 / DATA SCMIN1, BPMIN1, BRMIN1 / 0., 0., 0. / DATA SCMIN2, BPMIN2, BRMIN2 / 0., 0., 0. / DATA SCMIN3, BPMIN3, BRMIN3 / 0., 0., 0. / FKEYP2=PSQ/SQRT(FLOAT(NAT)) FCRIT=0.23 PSQCRT=0.3 IF ((FKEYP2.LT.FCRIT).OR.(KEYWIL.EQ.4).OR.(PSQ.LT.PSQCRT)) THEN IF (KEYWIL.EQ.4) THEN WRITE (LIS2, 50) 50 FORMAT(' Scale and/or temperature factors were found on', * ' CONDA-file and will be used.') ELSE WRITE (LIS2, 55) 55 FORMAT(' Known fragment is small: Smykalla-refinement', * ' is not executed!') WRITE (LIS2, 56)PSQ,FKEYP2 56 FORMAT(' (TEMP: p**2 and FPKEY2 are ',F5.2,' and ',F5.2,')') ENDIF RETURN ENDIF ITEST=0 EGRENS=AMAX1(PSQ,0.5) WCHOSE=.TRUE. IUNOBS=0 IREF=0 ITAB1=0 ITAB2=0 ITAB3=0 SQ2=SQRT(2.) ZRTMP=0. ZRTMPX=0. ZPTMPX=0. BRX=0. BPX=0. YX=0. FRY=0. FPY=0. CALL LOGRD (IDDL, 'MERBSC', KLOG) IF (KLOG .LT. 0 .OR. LIT(2) .NE. 'SCALE') THEN CHOUT=' MERBIN SCALE not found on DDLOG file: what happened?' CALL SHOUT CALL KERROR ('You cleared too much, probably!', 114, 'DDMINI') ENDIF SCAMER = FNUM(2) BOV = FNUM(3) DO 100 ISC=1,21 100 SCERR(ISC)=SCAMER*(1.+FLOAT(ISC-11)*DELTAS) CALL KERNZI (0,IPGO,567) CALL KERNZA (0.,FPGOS,54) CALL KERNZI (0,IREFST,54) CALL KERNZA (0.,PGO1,567) CALL KERNZA (0.,PGO2,567) CALL KERNZA (0.,PGOS1,54) CALL KERNZA (0.,PGOS2,54) CALL KERNZA (0.,BRVAR,30) CALL KERNZA (0.,BPVAR,30) CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO) CALL BINIFF (1, IBINFC, 'BINFC', FITFC, NITFC, BUFFC,KENDFC) BPINP=BUFFC(19) BOV = BUFFC(17) IEXS=1 EXVAR1=0. EXVAR2=0. E2AVE=0. RSCAVE=0. E2SDIF=0. RSCDIF=0. IAVE=0 130 CALL BINIFF (0, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO) IF (KENDFO.LT.0) GOTO 210 CALL BINIFF (0, IBINFC, 'BINFC', FITFC, NITFC, BUFFC,KENDFC) IF (KENDFC.LT.0) CALL KERROR ('BINFC cut-off ?', 0, 'SCASTA') IF (FP .LT. -990.) GOTO 130 JCODE=1 IF (FOBS.LT.5.*SIG) JCODE=2 CALL HKLC1U (HCODE, HKLX) CALL HKLSTL (HKLX, STL, STL2) ISS = IFIX (STL*400. + 1.5) CALL HKLEX1 (HKLX, HKLX) CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2) EPSIL = IEPS SUMF2R=SUMF2(ISS)-SUMF2P(ISS) ZTMP = SQRT (SUMF2(ISS) * EPSIL * ALATT) * EXP(-BOV*STL2) ZPTMP= SQRT (SUMF2P(ISS) * EPSIL * ALATT) * EXP(-BOV*STL2) ZRTMP= SQRT (SUMF2R * EPSIL * ALATT) * EXP(-BOV*STL2) YBOV = FP * EXP((-BOV+BPINP)*STL2) Y = FP * EXP((-BP+BPINP)*STL2) IF (ABS(Y) .LT. 0.0001) GOTO 130 IF (ICENT.EQ.1) THEN IF (ITAB1.EQ.100) ITAB2=ITAB2+1 ITAB1 = MOD(ITAB1,100)+1 ITAB2 = MOD(ITAB2,100)+1 ER = SQRT(AVAL(ITAB1)**2+BVAL(ITAB2)**2) PHIR = ATAN2(BVAL(ITAB2),AVAL(ITAB1)) ELSE ITAB3= MOD(ITAB3,200)+1 ER = 0. PHIR = 0. ENDIF EOB = (SCALE * FOBS) / ZTMP IF (EOB.GT.EGRENS) THEN IF (JCODE.EQ.2) IUNOBS = IUNOBS+1 IREF=IREF+1 ENDIF FBEX(1)=-1*BOVVAR FBEX(2)=0. FBEX(3)=BOVVAR IF (BOV.LT.BOVVAR*2) THEN FBEX(1)=AMIN1(BOV,BOVVAR)-BOV IF (ABS(FBEX(1)).LT.0.00001) IEXS=2 ENDIF IF (BOV.GT.BOVVAR*10) THEN FBEX(1)=-0.1*BOV FBEX(3)=0.1*BOV ENDIF DO 140 IB=1,10 DO 140 IEX=IEXS,3 BOVCOR=EXP(-1*FBEX(IEX)*STL2) IF ((IB.EQ.10.AND.IEX.EQ.1).OR.(IB.EQ.10.AND.IEX.EQ.2)) GOTO 140 IF (IB.LT.10) THEN IF (PSQ.GT.0.5) THEN BRVAR(IB,IEX) = (BOV+FBEX(IEX))*(FLOAT(IB-5)*DELTAB) BPVAR(IB,IEX) = (BRVAR(IB,IEX) * (PSQ-1))/PSQ ELSE BPVAR(IB,IEX) = (BOV+FBEX(IEX)) * (FLOAT(IB-5)*DELTAB) BRVAR(IB,IEX) = (BPVAR(IB,IEX)*PSQ)/(PSQ-1) ENDIF EXVAR1 = EXP(-BRVAR(IB,IEX)*STL2) EXVAR2 = EXP(-BPVAR(IB,IEX)*STL2) ENDIF IF (IB.EQ.10) THEN ZRTMPX= SQRT (SUMF2R * EPSIL * ALATT) * EXP(-BR*STL2) ZPTMPX= SQRT (SUMF2P(ISS) * EPSIL * ALATT) * EXP(-BP*STL2) YX=Y ELSE ZRTMPX = ZRTMP * EXVAR1 * BOVCOR ZPTMPX = ZPTMP * EXVAR2 * BOVCOR YX = YBOV * EXVAR2 * BOVCOR ENDIF FPX=0. IF (ICENT.EQ.1) THEN FPX= YX * COS(PHIP/RAD) FRSTAT=ER*ZRTMPX XO= FPX+(FRSTAT*COS(PHIR)) YO= (YX*SIN(PHIP/RAD))+(FRSTAT*SIN(PHIR)) FO= SQRT((XO**2)+(YO**2)) ELSE FRX= CVAL(ITAB3)*ZRTMPX*SQ2 FO= ABS(YX+FRX) ENDIF EO= FO/SQRT(ZPTMPX**2+ZRTMPX**2) IF (IB.LT.10) THEN DO 135 IEO=0,1 EGR=EGRENS+(IEO*0.1) JEO=IEO+1 IF (EO.GT.EGR) THEN IREFST(JEO,IB,IEX) = IREFST(JEO,IB,IEX)+1 IF (ABS(YX).GT.FO) FPGOS(JEO,IB,IEX)=FPGOS(JEO,IB,IEX)+1. IF (WCHOSE) THEN PGOS1(JEO,IB,IEX)=PGOS1(JEO,IB,IEX)+ * ((ABS(YX)-FO)/SQRT(SUMF2(ISS))) PGOS2(JEO,IB,IEX)=PGOS2(JEO,IB,IEX)+ * (ABS(YX)/SQRT(SUMF2(ISS))) ELSE PGOS1(JEO,IB,IEX)=PGOS1(JEO,IB,IEX)+(ABS(YX)-FO) PGOS2(JEO,IB,IEX)=PGOS2(JEO,IB,IEX)+ABS(YX) ENDIF ENDIF 135 CONTINUE ENDIF IF (IB.LT.10) THEN IF (EOB.GT.EGRENS) THEN DO 150 ISC=1,21 FSC = FOBS * SCERR(ISC) IF (ABS(YX).GT.FSC) IPGO(IB,ISC,IEX)=IPGO(IB,ISC,IEX)+1 IF (WCHOSE) THEN PGO1(IB,ISC,IEX)=PGO1(IB,ISC,IEX)+ * ((ABS(YX)-FSC)/SQRT(SUMF2(ISS))) PGO2(IB,ISC,IEX)=PGO2(IB,ISC,IEX)+ * (ABS(YX)/SQRT(SUMF2(ISS))) ELSE PGO1(IB,ISC,IEX)=PGO1(IB,ISC,IEX)+(ABS(YX)-FSC) PGO2(IB,ISC,IEX)=PGO2(IB,ISC,IEX)+ABS(YX) ENDIF 150 CONTINUE ENDIF ENDIF 140 CONTINUE GOTO 130 210 DO 215 IB=1,9 DO 215 IEX=IEXS,3 FRFDIF=FLOAT(ABS(IREFST(1,IB,IEX)-IREFST(2,IB,IEX))) IF(FRFDIF.GT.0.001) THEN FINTPO=FLOAT(IREFST(2,IB,IEX)-IREF)/FRFDIF ELSE FINTPO = 0.0 ENDIF FPGOSD=FPGOS(2,IB,IEX)-FPGOS(1,IB,IEX) PGOSD1=PGOS1(2,IB,IEX)-PGOS1(1,IB,IEX) PGOSD2=PGOS2(2,IB,IEX)-PGOS2(1,IB,IEX) FPGOS(1,IB,IEX)=FPGOS(2,IB,IEX)+FINTPO*FPGOSD PGOS1(1,IB,IEX)=PGOS1(2,IB,IEX)+FINTPO*PGOSD1 PGOS2(1,IB,IEX)=PGOS2(2,IB,IEX)+FINTPO*PGOSD2 215 CONTINUE CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO) CALL BINIFF (1, IBINFC, 'BINFC', FITFC, NITFC, BUFFC,KENDFC) DO 230 IB=1,9 DO 230 IEX=IEXS,3 FOMOL1=0. FOMOL2=0. SCOKE1=0. SCOKE2=0. SCOK1=.FALSE. SCOK2=.FALSE. FOM1ST=FPGOS(1,IB,IEX)/FLOAT(IREF) FOM2S=PGOS1(1,IB,IEX)/PGOS2(1,IB,IEX) DO 220 ISC=1,21 FOM1=(FLOAT(IPGO(IB,ISC,IEX))/FLOAT(IREF))-FOM1ST FOM2=(PGO1(IB,ISC,IEX)/PGO2(IB,ISC,IEX))-FOM2S IF (ISC.NE.1) THEN SCDIF=SCERR(ISC)-SCERR(ISC-1) IF (.NOT. SCOK1) THEN IF (FOM1.LE.0) THEN FOMDIF=ABS(FOM1-FOMOL1) SCOKE1=SCERR(ISC)+((FOM1/FOMDIF)*SCDIF) SCOK1=.TRUE. ELSE IF (ISC.EQ.21) SCOKE1=SCERR(ISC) ENDIF ENDIF IF (.NOT. SCOK2) THEN IF (FOM2.LE.0.) THEN FOMDIF=ABS(FOM2-FOMOL2) SCOKE2=SCERR(ISC)+((FOM2/FOMDIF)*SCDIF) SCOK2=.TRUE. ELSE IF (ISC.EQ.21) SCOKE2=SCERR(ISC) ENDIF ENDIF ELSE IF (FOM1.LE.0) THEN SCOKE1=SCERR(1) SCOK1=.TRUE. ENDIF IF (FOM2.LE.0) THEN SCOKE2=SCERR(1) SCOK2=.TRUE. ENDIF ENDIF FOMOL1=FOM1 FOMOL2=FOM2 220 CONTINUE SCTAB(1,IB,IEX)=SCOKE1 SCTAB(2,IB,IEX)=SCOKE2 230 CONTINUE WRITE(LIS2,243) 243 FORMAT (' ') WRITE(LIS2,244) WRITE(LIS1,244) 244 FORMAT (' New refinement of SCALE, Bp and Br:', *' (Israel et al., Z. f. Krist., 1995)') WRITE(LIS2,FMT='('' Bp Br scale Ra '', * '' DaRa Rb DbRb FOM3'')') R2CALT = 0. BPINP=BUFFC(19) CALL KERNZA(0.,E2SUMT,54) CALL KERNZA(0.,E2FOM,54) CALL KERNZA(0.,RSCTL,54) CALL KERNZA(0.,RSCNM,54) CALL KERNZA(0.,RSC,54) RSCTL2=0. RSCNM2=0. E2SMT2=0. E2SMAX=-999. RSCMAX=-999. E2SMIN=999. RSCMIN=999. FOMMN1=999. FOMMN2=999. FOMMN3=999. ITPX = 0 250 CALL BINIFF (0, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO) IF (KENDFO.LT.0) GOTO 310 CALL BINIFF (0, IBINFC, 'BINFC', FITFC, NITFC, BUFFC,KENDFC) IF (KENDFC.LT.0) CALL KERROR ('BINFC cut-off ?', 0, 'SCASTA') IF (FP .LT. -990.) GOTO 250 JCODE=1 IF (FOBS.LT.5.*SIG) JCODE=2 CALL HKLC1U (HCODE, HKLX) CALL HKLSTL (HKLX, STL, STL2) ISS = IFIX (STL*400. + 1.5) CALL HKLEX1 (HKLX, HKLX) CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2) EPSIL = FLOAT(IEPS) SUMF2R=SUMF2(ISS)-SUMF2P(ISS) ZTMP = SQRT (SUMF2(ISS) * EPSIL * ALATT) * EXP(-BOV*STL2) ZRTMP= SQRT (SUMF2R * EPSIL * ALATT) * EXP(-BOV*STL2) ZPTMP= SQRT (SUMF2P(ISS) * EPSIL * ALATT) * EXP(-BOV*STL2) YBOV = FP * EXP((-BOV+BPINP)*STL2) Y = FP * EXP((-BP+BPINP)*STL2) DO 280 IFOM=1,3 M=3 N=9 IF (IFOM.EQ.3) THEN M=IEXS N=1 ENDIF DO 280 IB=1,N DO 280 IEX=IEXS,M BOVCOR=EXP(-1*FBEX(IEX)*STL2) IF (IFOM.NE.3) THEN EXVAR1 = EXP(-BRVAR(IB,IEX)*STL2) EXVAR2 = EXP(-BPVAR(IB,IEX)*STL2) ZRTMPX = ZRTMP * EXVAR1 * BOVCOR ZPTMPX = ZPTMP * EXVAR2 * BOVCOR YX = YBOV * EXVAR2 * BOVCOR FSC=FOBS*SCTAB(IFOM,IB,IEX) ELSE ZRTMPX = SQRT (SUMF2R * EPSIL * ALATT) * EXP(-BR*STL2) YX = Y FSC=FOBS*SCALE ENDIF FONRM = (FSC*FSC)/SUMF2(ISS) FPNRM = (YX*YX)/SUMF2(ISS) FRNRM = (ZRTMPX*ZRTMPX)/SUMF2(ISS) IF (IFOM.NE.3) THEN RSCTL(IFOM,IB,IEX)=RSCTL(IFOM,IB,IEX)+(FONRM-FPNRM-FRNRM)**2 RSCNM(IFOM,IB,IEX)=RSCNM(IFOM,IB,IEX)+FONRM**2 ELSE RSCTL2=RSCTL2+(FONRM-FPNRM-FRNRM)**2 RSCNM2=RSCNM2+FONRM**2 ENDIF ITPX = IPHFIX(HKLX) - 1 E1T = (FSC-YX) / ZRTMPX E1ST = ABS(E1T) IF (E1ST.GT.4.) E1ST = 4. IF (JCODE.LE.1) GOTO 270 IF (E1T.GT.0.) GOTO 260 E1T = (1.4*FSC - YX)/ZRTMPX IF (E1T.GT.0.) E1 = 0.0 GOTO 270 260 E1T = (0.7*FSC - YX)/ZRTMPX IF (E1T.LT.0.0) E1T = 0.0 270 E2T = (FSC+YX) / ZRTMPX IF (JCODE.GT.1) E2T = AMAX1(YX/ZRTMPX, E1T) CALL W1PROB (ITPX, E1T, E2T, PT) EEX = E2EXP(ITPX, E1ST, E2T) IF (IFOM.NE.3) THEN E2SUMT(IFOM,IB,IEX) = E2SUMT(IFOM,IB,IEX) + EEX ELSE E2SMT2=E2SMT2+EEX ENDIF 280 CONTINUE GOTO 250 310 DO 320 IFOM=1,2 DO 320 IB=1,9 DO 320 IEX=IEXS,3 E2SUMT(IFOM,IB,IEX)=E2SUMT(IFOM,IB,IEX)/FLOAT(NREFL) E2FOM(IFOM,IB,IEX)=0. IF (E2SUMT(IFOM,IB,IEX).LT.1.0) * E2FOM(IFOM,IB,IEX)=2*ABS(1.0-E2SUMT(IFOM,IB,IEX)) IF (E2SUMT(IFOM,IB,IEX).GT.1.1) * E2FOM(IFOM,IB,IEX)=ABS(1.1-E2SUMT(IFOM,IB,IEX)) E2AVE=E2AVE+E2FOM(IFOM,IB,IEX) RSC(IFOM,IB,IEX)=RSCTL(IFOM,IB,IEX)/RSCNM(IFOM,IB,IEX) RSCAVE=RSCAVE+RSC(IFOM,IB,IEX) IAVE=IAVE+1 320 CONTINUE E2SMT2=E2SMT2/NREFL E2FOM2=0. IF (E2SMT2.LT.1.0) E2FOM2=2*ABS(1.0-E2SMT2) IF (E2SMT2.GT.1.1) E2FOM2=ABS(1.1-E2SMT2) IAVE=IAVE+1 E2AVE=(E2AVE+E2FOM2)/FLOAT(IAVE) RSC2=RSCTL2/RSCNM2 RSCAVE=(RSCAVE+RSC2)/FLOAT(IAVE) DO 321 IFOM=1,2 DO 321 IB=1,9 DO 321 IEX=IEXS,3 ATERM=ABS(E2FOM(IFOM,IB,IEX)-E2AVE) BTERM=ABS(RSC(IFOM,IB,IEX)-RSCAVE) E2SDIF=E2SDIF+ATERM RSCDIF=RSCDIF+BTERM 321 CONTINUE ATERM=ABS(E2FOM2-E2AVE) BTERM=ABS(RSC2-RSCAVE) E2SDIF=AMAX1((E2SDIF+ATERM)/FLOAT(IAVE),0.1) RSCDIF=AMAX1((RSCDIF+BTERM)/FLOAT(IAVE),0.01) FOM3P1=RSCDIF*E2FOM2 FOM3P2=E2SDIF*RSC2 FOM3=FOM3P1+FOM3P2 WRITE(LIS2,FMT='(8F10.5)')BP,BR,SCALE,E2FOM2,FOM3P1,RSC2,FOM3P2, * FOM3 IF (FOM3.LT.FOMMN1) THEN FOMMN1=FOM3 SCMIN1=SCALE BPMIN1=BP BRMIN1=BR ENDIF DO 330 IFOM=1,2 WRITE(LIS2,FMT='('' FOM'',I1,''-------------------'')')IFOM DO 330 IB=1,9 DO 330 IEX=IEXS,3 BPX = (BOV+FBEX(IEX)) + BPVAR(IB,IEX) BRX = (BOV+FBEX(IEX)) + BRVAR(IB,IEX) FOM3P1=RSCDIF*E2FOM(IFOM,IB,IEX) FOM3P2=E2SDIF*RSC(IFOM,IB,IEX) FOM3=FOM3P1+FOM3P2 IF (FOM3.LT.FOMMN1) THEN FOMMN3=FOMMN2 BPMIN3=BPMIN2 BRMIN3=BRMIN2 SCMIN3=SCMIN2 FOMMN2=FOMMN1 BPMIN2=BPMIN1 BRMIN2=BRMIN1 SCMIN2=SCMIN1 FOMMN1=FOM3 BPMIN1=BPX BRMIN1=BRX SCMIN1=SCTAB(IFOM,IB,IEX) GOTO 329 ENDIF IF ((FOM3.LT.FOMMN2).AND.(FOM3.GT.FOMMN1))THEN FOMMN3=FOMMN2 BPMIN3=BPMIN2 BRMIN3=BRMIN2 SCMIN3=SCMIN2 FOMMN2=FOM3 BPMIN2=BPX BRMIN2=BRX SCMIN2=SCTAB(IFOM,IB,IEX) GOTO 329 ENDIF IF ((FOM3.LT.FOMMN3).AND.(FOM3.GT.FOMMN2)) THEN FOMMN3=FOM3 BPMIN3=BPX BRMIN3=BRX SCMIN3=SCTAB(IFOM,IB,IEX) ENDIF 329 WRITE(LIS2,FMT='(8F10.5)')BPX,BRX,SCTAB(IFOM,IB,IEX), * E2FOM(IFOM,IB,IEX),FOM3P1,RSC(IFOM,IB,IEX),FOM3P2,FOM3 330 CONTINUE WRITE(LIS2,FMT='('' Best solutions: '')') WRITE(LIS2, 333) BPMIN1, BRMIN1, SCMIN1, FOMMN1 WRITE(LIS2, 333) BPMIN2, BRMIN2, SCMIN2, FOMMN2 WRITE(LIS2, 333) BPMIN3, BRMIN3, SCMIN3, FOMMN3 333 FORMAT (' Bp ',F7.3, ' Br ', F7.3, ' Sc ',F7.3,' FOM3 ',F7.5) WRITE (LIS2, 334) 334 FORMAT (' We selected the first solution for further', * ' calculations!') WRITE (LIS1, 335) 335 FORMAT (' New values are:') SCALE=SCMIN1 BP=BPMIN1 BR=BRMIN1 WRITE (LIS1, 336) BP, BR, SCALE 336 FORMAT (' Bp = ', F6.3, ' Br = ', F6.3, ' Scale = ', F9.5) WRITE (CHOUT, 337) SCALE, BP, BR 337 FORMAT ('SCALE ', F14.7, ' BP ', F11.5, ' BR ', F10.5) CALL LOGWR (IDDL) CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO) CALL BINIFF (1, IBINFC, 'BINFC', FITFC, NITFC, BUFFC,KENDFC) END SUBROUTINE CONFI (KEY, KEND) 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 EQUIVALENCE (ICONA, IFILE(1)), (ICONI, IFILE(2)) EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)), (IHELP, IFILE(9)) DIMENSION KRICH(2,32) CHARACTER*1 LRICH(2,32) KEND = 0 IF (KEY .GT. 0) GOTO 337 IF (KEY .LT. 0) RETURN CALL XHELP (IHELP, LIS1, 875. ) READ (IHELP, 404, END=600) KODE = 0 103 READ (IHELP, 404, END=600) (KRICH(1,L), L=1,32) IF (KRICH(1,1) .GT. 77) RETURN READ (IHELP, 404, END=600) (KRICH(2,L), L=1,32) K=1 DO 113 L = 32, 1, -1 IF (KRICH(K,L) .NE. 0) GOTO 117 KRICH(K,L) = 10 113 CONTINUE 117 CONTINUE DO 122 L = 1,32 I = KRICH(K,L) CALL KERICH (I, LRICH(K,L), KEND) 122 CONTINUE DO 143 L = 2, 26, 6 M = L + 5 N = 0 KODE = KODE + 1 DO 140 J = L, M N = N + 1 IF (LRICH(K,J) .NE. CCODE(N:N)) GOTO 143 140 CONTINUE KEND = KODE RETURN 143 CONTINUE GOTO 103 337 FFF = KEY CALL XHELP (IHELP, LIS1, FFF ) READ (IHELP, 404, END=600) 403 READ (IHELP, 404, END=600) (KRICH(1,L), L=1,32) 404 FORMAT (32I2) IF (KRICH(1,1) .GT. 77) RETURN READ (IHELP, 404, END=600) (KRICH(2,L), L=1,32) DO 422 K=1,2 DO 413 L = 32, 1, -1 IF (KRICH(K,L) .NE. 0) GOTO 417 KRICH(K,L) = 10 413 CONTINUE 417 CONTINUE DO 422 L = 1,32 I = KRICH(K,L) CALL KERICH (I, LRICH(K,L), KEND) 422 CONTINUE WRITE (LIS1, 424) ((LRICH(K,L), L=1,32), K=1,2) WRITE (IPR1, 424) ((LRICH(K,L), L=1,32), K=1,2) 424 FORMAT (64A) GOTO 403 600 KEND = -1 CONTINUE RETURN END SUBROUTINE GETR2X (KEY, IATOLD, IRUN, R2CYC, KEND) DIMENSION R2CYC(20) 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 KEND = 0 IF (KEY .NE. 0) GOTO 813 CALL KERNZA (-1.0, R2CYC, 20) NCYT = 0 NCY = 0 CALL FILINQ (IATOLD, 'ATOLD', 'FORMATTED', 'INPUT', KINQ) IF (KINQ.EQ.-1) THEN CALL FILCLO (IATOLD, 'KEEP') RETURN ENDIF 313 CALL KERINA (IATOLD, LIT, 1, LEND) IF (LEND .EQ. 5) GOTO 713 IF (LEND .LT. 0) GOTO 713 IF (LIT(1) .NE. 'ATOMS') GOTO 313 CALL KERING ('RUN', N) IF (N .LE. 0) GOTO 313 NRUN = NINT (FNUM(N)) IF (NRUN .NE. IRUN) GOTO 313 CALL KERING ('CY=', N) IF (N .LE. 0) GOTO 313 NCYT = NINT (FNUM(N)) IF (NCYT .LE. 0 .OR. NCYT .GT. 20) GOTO 313 CALL KERING ('R2X=', N) IF (N .LE. 0) GOTO 313 R2X = FNUM(N) IF (R2X .LE. -0.001 .OR. R2X .GT. 9.999) GOTO 313 NCY = NCYT R2CYC(NCY) = R2X GOTO 313 713 CALL FILCLO (IATOLD, 'KEEP') KEND = NCY RETURN 813 CONTINUE CALL FILINQ (IATOLD, 'ATOLD', 'FORMATTED', 'INPUT', KINQ) IF (KINQ.EQ.-1) THEN CALL FILCLO (IATOLD, 'KEEP') RETURN ENDIF KEY1 = KEY - 1 823 CALL KERINA (IATOLD, LIT, 1, LEND) IF (LEND .EQ. 5) GOTO 893 IF (LEND .LT. 0) GOTO 893 IF (LIT(1) .NE. 'ATOMS') GOTO 823 CALL KERING ('RUN', N) IF (N .LE. 0) GOTO 823 NRUN = NINT (FNUM(N)) IF (NRUN .NE. IRUN) GOTO 823 CALL KERING ('CY=', N) IF (N .LE. 0) GOTO 823 NCYT = NINT (FNUM(N)) IF (NCYT .LT. KEY1) GOTO 823 IF (NCYT .GT. KEY1) CALL KERROR (' ?? ', 823, 'GETR2X') CALL KERING ('R2X=', N) IF (N .LE. 0) GOTO 823 KEND = 1 BACKSPACE IATOLD RETURN 893 CALL FILCLO (IATOLD, 'KEEP') RETURN END SUBROUTINE KERING (ALI, KEND) CHARACTER ALI *(*) 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 * 6 ALIT ALIT = ALI IF (NLIT .LE. 0) GOTO 202 DO 200 L = 1, NLIT IF (LIT(L) .NE. ALIT) GOTO 200 LCOL = NCOLL(L) LCOL2 = 99 IF (L .LT. NLIT) NCOL2 = NCOLL(L+1) IF (LCOL2 .LT. 0) LCOL2 = 99 GOTO 250 200 CONTINUE 202 KEND = -1 RETURN 250 IF (NFNUM .LE. 0) GOTO 302 DO 300 N = 1, NFNUM NCOL = NCOLN(N) IF (NCOL .LE. 0) GOTO 302 IF (NCOL .LT. LCOL) GOTO 300 IF (NCOL .GT. LCOL2) GOTO 302 KEND = N RETURN 300 CONTINUE 302 KEND = -2 RETURN END SUBROUTINE DICALC 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 EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IBINFO, IFILE(11)), (IBINFC, IFILE(12)) LOGICAL 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 /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) DIMENSION FITFO(3), FITFC(2), FITFC2(51) EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1)) PARAMETER (MAXAT = 993) PARAMETER (MAXBUF = 198) COMMON / / SICO(12500), FF(500,10), EXPBP(500), EXPBR(500), * SUMF2(500), SUMF2P(500), SFAC(13,10), * ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT, * BUFFO(MAXBUF), BUFFC(MAXBUF), BUFBUF(MAXBUF) DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) COMMON /ATNAMA/ ATNAME(MAXAT) CHARACTER * 6 ATNAME COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV, * SUMX, SUMY, SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2, * NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF, * KEYT, KEYRET, JCODE, SUMF2R, Y, X, XSIG, * ITP, E1, E2, KEYDX, KEYDS, * NITFO, NITFC, NITDUA, NITDIF, NITFFT, * KENDFO, KENDFC, KENDUA, KENDIF, KENDFF, * FITDUA(7), FITDIF(4), FITFFT(5), * BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF) DIMENSION IHKL(3), HKLXX(3,24) KEYDX = KEYD KEYRET = 0 IF (KEYD.EQ.1) WRITE (LIS2, FMT = * '('' Prepare input for program PHASEX'')') IF (KEYD.EQ.2 .OR. KEYD.EQ.3) WRITE (LIS2, FMT = * '('' Prepare input for program FOUR'')') 200 IF (KEYD.NE.4) CALL DIDUAL (-1) IF (KEYD.EQ.2 .OR. KEYD.EQ.3) CALL DIFFT (-1) IF (KEYD.EQ.4) CALL DIPATT (-1) ITP = 0 LOOPFP = 1 IF (EXPAND) LOOPFP = NSYMM NR = 0 EPSIL2 = 1. 210 KEYDX = KEYD CALL BINIFF (0, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO) IF (KENDFO.LT.0) GOTO 230 IF (KEYD.EQ.4) GOTO 215 IF (.NOT. EXPAND) THEN CALL BINIFF (0, IBINFC, 'BINFC', FITFC, NITFC, BUFFC,KENDFC) ELSE CALL BINIFF (0, IBINFC, 'BINFC2', FITFC2, NITFC, BUFFC,KENDFC) ENDIF IF (KENDFC.LT.0) CALL KERROR ('BINFC cut-off ?', 0, 'DICALC') IF (EXPAND) THEN IF (EPSIL2.LT.-990.) GOTO 210 ELSE IF (FP.LT.-990.) GOTO 210 ENDIF 215 JCODE = 1 IF (FOBS .LT. 5.*SIG) JCODE = 2 CALL HKLC1U (HCODE, HKLX) CALL HKLSTL (HKLX, STL, STL2) ISS = IFIX (STL * 400. + 1.5) SUMF2R = SUMF2(ISS) - SUMF2P(ISS) IF (SUMF2R.LT.0.001) SUMF2R = 0.001 X = FOBS * SCALE XSIG = SIG * SCALE IF (KEYD.EQ.4) THEN NR = NR + 1 CALL DIPATT (0) GOTO 210 ENDIF IF (EXPAND) CALL HKLEX1 (HKLX, HKLXX) DO 229 IFP=1,LOOPFP IF (EXPAND) THEN KEYDX = KEYD FP = FPEXP(1,IFP) IF (FP .LT. 0.0) GOTO 229 PHIP = FPEXP(2,IFP) HKLX(1,1) = HKLXX(1,IFP) HKLX(2,1) = HKLXX(2,IFP) HKLX(3,1) = HKLXX(3,IFP) CALL HKLC1 (HKLX, HCODE) ENDIF NR = NR + 1 IF (KEYT.EQ.1) THEN Y = FP * EXP((-BP+BPINP)*STL2) ELSE Y = FP ENDIF IF (EXPAND) GOTO 221 ITP = IPHFIX(HKLX) - 1 IF (ITP .LT. -1) THEN CALL KERF2I (HKLX, IHKL, 3) WRITE (LIS1, 220) (IHKL(I), I=1,3) 220 FORMAT (' Reflection ',3I3, ' gives impossible phase restr.') CALL KERNER (220, 'DICALC') ENDIF 221 IF (KEYD.EQ.2) CALL DIFFT (0) IF (KEYD.EQ.3 .AND. KEYDS.GE.4) GOTO 228 IF (KEYDX.NE.2) CALL DIDUAL (0) 228 IF (KEYDX.EQ.3) CALL DIFFT (0) 229 CONTINUE GOTO 210 230 IF (KEYD .EQ. 2 .OR. KEYD .EQ. 3) CALL FILCLO (IBINFC, 'DELETE') IF (KEYD.EQ.2) THEN CALL DIFFT (1) RETURN ENDIF IF (KEYD.EQ.4) THEN CALL DIPATT (1) RETURN ENDIF IF (KEYD.EQ.3 .AND. KEYDS.GE.4) THEN CALL DIFFT (1) RETURN ENDIF CALL DIDUAL (1) IF (KEYRET.LT.10) GOTO 200 IF (KEYD.EQ.3) CALL DIFFT (1) RETURN END SUBROUTINE DIDUAL (KEY) 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 SWPRI, EXPAND EQUIVALENCE (SWPRI, SWITCH(10)), (EXPAND, SWITCH(23)) EQUIVALENCE (IDDL, IFILE(1)), (LIS2, IFILE(8)) EQUIVALENCE (IE100, IFILE(10)) EQUIVALENCE (IBINFO, IFILE(11)), (IBINFC, IFILE(12)) EQUIVALENCE (IBINDU, IFILE(14)), (IBINFF, IFILE(16)) 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 /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) DIMENSION FITFO(3), FITFC(2), FITFC2(51) EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1)) PARAMETER (MAXAT = 993) PARAMETER (MAXBUF = 198) COMMON / / SICO(12500), FF(500,10), EXPBP(500), EXPBR(500), * SUMF2(500), SUMF2P(500), SFAC(13,10), * ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT, * BUFFO(MAXBUF), BUFFC(MAXBUF), BUFBUF(MAXBUF) DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) COMMON /ATNAMA/ ATNAME(MAXAT) CHARACTER * 6 ATNAME COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV, * SUMX, SUMY, SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2, * NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF, * KEYT, KEYRET, JCODE, SUMF2R, Y, X, XSIG, * ITP, E1, E2, KEYDX, KEYDS, * NITFO, NITFC, NITDUA, NITDIF, NITFFT, * KENDFO, KENDFC, KENDUA, KENDIF, KENDFF, * FITDUA(7), FITDIF(4), FITFFT(5), * BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF) EQUIVALENCE (FITDUA(4), ZSCATT), (FITDUA(5), P1), (FITDUA(6), P2), * (FITDUA(7), W1) PARAMETER (PSQMIN = 0.15, E1MINP = 0.9) DIMENSION DEG(8), IHKL(3), W1LIM(6), EPLIM(6) DIMENSION HKLM(3), HKLMA(3), HKLMI(3) CHARACTER * 7 RESTR(9) DATA ESUMMI / .50 / DATA W1LIM / .001, .050, .200, .800, .999, 1.000 / DATA EPLIM / .01, .20, .60, 1.00, 1.50, 10.000 / DATA DEG / 0., 30., 45., 60., 90., 120., 135., 150. / DATA RESTR / ' NONE', ' 0/180', ' 30/210', * ' 45/225', ' 60/240', ' 90/270', * '120/300', '135/315', '150/330' / DATA PSQX, NGN, NSP, NR1, NPP, IEPS / 0.0 , 0, 0, 0, 0, 0 / DATA HKMAX, NGNLE,NSPLE, E2CLE,E2ALE, NE1ALL /0., 0, 0, 0., 0., 0/ DATA E1MIN / 0./ IF (KEY) 200, 240, 380 200 E2SUM = 0. E2ALE = 0. E2CLE = 0. NSP = 0 NGN = 0 NSPLE = 0 NGNLE = 0 SUMX = 0. SUMX2 = 0. SUMY2 = 0. SUMXY = 0. CALL KERNZI (0, NUMW1, 6) CALL KERNZI (0, NUMEP, 6) CALL KERNZI (0, NUMEP2, 6) IF (NREFL .GT. 1000) THEN E1MIN = E1MINP ELSE IF (NREFL .GT. 500) THEN E1MIN = 0.7 ELSE E1MIN = 0.5 ENDIF WRITE(LIS2, FMT = '('' E1MIN reset to: '', F6.3)') E1MIN ENDIF EPSIL = 1. IEPS = 1 IF (KEYD.EQ.1) THEN CALL KERNZA (-9999., HKLM, 3) CALL KERNZA (-9999., HKLMA, 3) CALL KERNZA ( 9999., HKLMI, 3) HKMAX = 0.0 ENDIF IF (SWPRI .AND. KEYD.NE.2) THEN NPP = MAX0(1,(NREFL/40)) IF (KEYD.EQ.1) NPP = MAX0(1,(NREFL/160)) WRITE (LIS2, FMT='(''0Print every '', I3, * ''th- reflection'')') NPP IF (KEYD .EQ. 1) WRITE (LIS2, FMT='(''+'', 31X, * ''(accepted for PHASEX)'')') IF (KEYD .EQ. 3) WRITE (LIS2, FMT='(''+'', 31X, * ''(accepted for FOUR)'')') WRITE (LIS2, 230) 230 FORMAT (' H K L JC EPS FO*SC FP(BP) ', * 'PHASE REST. PH P1 P2 W1 E1 E2') ENDIF NR1 = 0 NE1ALL = 0 PSQX = PSQ IF (EXPAND) PSQX = P1SQ HMUL = 1.0 IF (NREFL .GT. 5000) HMUL = 0.5 HKLX(1,1) = HKLMAX(1) * HMUL HKLX(2,1) = HKLMAX(2) * HMUL HKLX(3,1) = HKLMAX(3) * HMUL IF (PSQX.LE.PSQMIN) THEN CALL E1WEAK (1, HKLX, ESUM) IF (NREFL.LT.4000) ESUMMI = 1.0 ENDIF RETURN 240 CONTINUE IF (EXPAND) GOTO 255 IF (ITP.EQ.0) GOTO 250 DIF = ABS(DEG(ITP) - PHIP) DIF = MIN1(DIF, 360.-DIF) PHIP = DEG(ITP) IF (DIF.GT.90.) PHIP = PHIP + 180. 250 CALL HKLEX1 (HKLX, HKLX) CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2) EPSIL = FLOAT(IEPS) 255 Z = SQRT (SUMF2R * EPSIL * ALATT) * EXP(-BR*STL2) IF (FOBS.LT.0.0001) THEN FOBS = 0.0001 X = 0.0001 * SCALE ENDIF EOBS = X / Z SIGE = SIG*SCALE / Z ZSCATT = Z E1 = (X-Y) / Z SUMX = SUMX + X SUMX2 = SUMX2 + X*X SUMY2 = SUMY2 + Y*Y SUMXY = SUMXY + ABS(X-Y) E1STAT = ABS(E1) IF (E1STAT.GT.4.) E1STAT = 4. IF (JCODE.LE.1) GOTO 270 IF (E1.GT.0.) GOTO 260 E1 = (1.4*X - Y)/Z IF (E1.GT.0.) E1 = 0.0 GOTO 270 260 E1 = (0.7*X - Y)/Z IF (E1.LT.0.0) E1 = 0.0 270 P1 = PHIP IF (E1.LT.0.0) P1 = PHIP - 180. IF (P1.LT.-0.5) P1 = P1 + 360. E2 = (X+Y) / Z IF (JCODE.GT.1) E2 = AMAX1(Y/Z, E1) P2 = PHIP - 180. IF (P2.LT.-0.5) P2 = P2 + 360. CALL W1PROB (ITP, E1, E2, P) W1 = 4.0 * (P-0.5)**2 IF (P.LT.0.5) W1 = 0.0 EEX = E2EXP(ITP, E1STAT, E2) E2SUM = E2SUM + EEX CALL KERF2I (HKLX, IHKL, 3) IF (.NOT. SWPRI .OR. KEYD.EQ.2) GOTO 300 IF (KEYD.EQ.1 .AND. E1.LT.E1MIN) GOTO 300 IF (NR / NPP*NPP .NE. NR ) GOTO 300 IJ = ITP + 1 WRITE (LIS2, 290) (IHKL(I),I=1,3), JCODE, IEPS, X, Y, RESTR(IJ), * PHIP, P1, P2, W1, E1, E2 290 FORMAT (5I4, 2F10.3, 3X, A7, 2X, 3F8.0, 3F8.3) 300 IF (ITP.GE.1) NSP = NSP + 1 IF (ITP.EQ.0) NGN = NGN + 1 EP = 0.0 IF (SUMF2P(ISS).GT.0.000001) * EP = Y / SQRT(EPSIL * ALATT * SUMF2P(ISS)) DO 310 IEP=1,6 IF (EP.LT.EPLIM(IEP)) GOTO 320 310 CONTINUE IEP = 6 320 NUMEP(IEP) = NUMEP(IEP) + 1 IF (ABS(PHIP-P1) .LT. 90.) GOTO 330 NUMEP2(IEP) = NUMEP2(IEP) + 1 NUMW1(6) = NUMW1(6) + 1 GOTO 360 330 DO 340 I=1,5 IW1 = I IF (W1.LT.W1LIM(I)) GOTO 350 340 CONTINUE IW1 = 5 350 NUMW1(IW1) = NUMW1(IW1) + 1 360 CONTINUE IF (PSQX.GT.PSQMIN) GOTO 365 IF (IEPS.NE.1) GOTO 365 ESUM = E1 + EOBS + SIGE IF (ESUM.GT.ESUMMI) GOTO 365 NE1ALL = NE1ALL + 1 CALL E1WEAK (0, HKLX, ESUM) 365 IF (E1.GE.E1MIN .OR. KEYD.NE.1) GOTO 370 IF (ITP.EQ.0) THEN E2ALE = E2ALE + EEX NGNLE = NGNLE + 1 ELSE E2CLE = E2CLE + EEX NSPLE = NSPLE + 1 ENDIF RETURN 370 NR1 = NR1 + 1 IF (KEYD.NE.1) RETURN FITDUA(1) = HCODE FITDUA(2) = E1 FITDUA(3) = E2 CALL BINOFF (0, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA) DO 375 I=1,3 HKLMA(I) = AMAX1(HKLMA(I), HKLX(I,1)) 375 HKLMI(I) = AMIN1(HKLMI(I), HKLX(I,1)) HKMAX = AMAX1 (HKMAX, ABS(HKLX(1,1)-HKLX(2,1)) ) RETURN 380 KEYOLD = KEYRET CALL DIRESC (PSQX) IF (KEYOLD.EQ.KEYRET .OR. KEYRET.GT.2) GOTO 390 IF (KEYD.NE.1 .OR. EXPAND) GOTO 390 CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO) CALL BINIFF (1, IBINFC, 'BINFC', FITFC, NITFC, BUFFC,KENDFC) CALL BINIFF (1, IBINDU, 'BINDUA', FITDUA,NITDUA,BUFDUA,KENDUA) CALL BINOFF (6, IBINDU, 'BINDUA', FITDUA,NITDUA,BUFDUA,KENDUA) RETURN 390 IF (ICENT.EQ.1 .AND. .NOT.EXPAND) WRITE (LIS2, 400) NSP, NGN 400 FORMAT ('0Number of special reflections:', I6 / * ' Number of general reflections:', I6) IF (ICENT.EQ.2 .AND. .NOT. EXPAND ) WRITE (LIS2, 410) NSP IF (EXPAND) WRITE (LIS2, 410) NGN 410 FORMAT (23H Number of reflections:, I6 ) IF (KEYD.NE.1) GOTO 450 CALL BINOFF (-1, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA) WRITE (LIS2, 420) NR1, E1MIN 420 FORMAT (' Number of accepted reflections:', I6, * ' (E1 > ', F4.2, ', sent to PHASEX)') IF (ICENT.EQ.1 .AND. .NOT.EXPAND) * WRITE (LIS2, 430) NSP-NSPLE, NGN-NGNLE 430 FORMAT (' Number of accepted special reflections:', I6 / * ' Number of accepted general reflections:', I6) DO 435 I=1,3 435 HKLM(I) = AMAX1 (ABS(HKLMA(I)), ABS(HKLMI(I)) ) IF (ISYST.LE.3 .OR. EXPAND) GOTO 436 IF (ISYST.EQ.6 .OR. ISYST.EQ.7) * HKLM(1) = AMAX1 (HKLM(1),HKMAX) IF (ISYST.EQ.5 .OR. ISYST.EQ.8) * HKLM(1) = AMAX1 (HKLM(1),HKLM(3)) HKLM(1) = AMAX1 (HKLM(1),HKLM(2)) HKLM(2) = HKLM(1) IF (ISYST.EQ.5 .OR. ISYST.EQ.8) HKLM(3) = HKLM(1) 436 CONTINUE CALL KERF2I (HKLM, IHKL, 3) WRITE (CHOUT, 440) NAT, PSQX, IHKL, NR1 440 FORMAT ('PHASEX NAT',I4, ' PSQ',F6.3, ' MHKL',3I4, ' NREFL1',I7) CALL LOGWR (IDDL) CALL FILCLO (IDDL, 'KEEP') CALL FILINQ (IE100, 'E100', 'FORMATTED', 'OUTPUT', KINQ) WRITE (IE100, 442) CCODE, NGN, NSP, E2ALE, E2CLE 442 FORMAT ('E100 ', A6, 4X, 2I6, 2F7.0) IF (PSQX.LE.PSQMIN .AND. KEYD.EQ.1) THEN CALL E1WEAK (-1, HKLX, ESUM) WRITE (LIS2, 445) NREFL, NE1ALL, ESUMMI 445 FORMAT (' Number of all reflections : ', I6, / * ' Number of possible weak refl. : ', I6, / * ' (E1+Eobs+SIG(Eobs) < ', F4.2, ')') ELSE WRITE (IE100, FMT='(''END'')') ENDIF 450 KEYRET = 10 RETURN END SUBROUTINE E1WEAK (KEYE1, HKL, ESUM) DIMENSION HKL(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 EQUIVALENCE (LIS2, IFILE(8)) EQUIVALENCE (IE100, IFILE(10)) PARAMETER (MAXDAT = 100) DIMENSION DATE1(4, MAXDAT), HKLME1(3) DATA IE1 / 0 / IF (KEYE1.LE.0) GOTO 200 IE1 = MAXDAT + 1 CALL KERNZA (-1., DATE1, 4*MAXDAT) CALL KERNAB (HKL, HKLME1, 3) RETURN 200 IF (KEYE1.LT.0) GOTO 300 IF (ABS(HKL(1)).GT.HKLME1(1) .OR. ABS(HKL(2)).GT.HKLME1(2) .OR. * ABS(HKL(3)).GT.HKLME1(3)) RETURN IE1 = IE1 - 1 DO 210 J=MAXDAT,IE1+1,-1 IF (ESUM.GE.DATE1(4,J)) GOTO 210 JJ = J GOTO 220 210 CONTINUE JJ = IE1 IF (IE1.EQ.0) THEN IE1 = 1 RETURN ENDIF GOTO 240 220 IF (IE1.EQ.0) IE1 = 1 DO 230 J=IE1+1,JJ DO 230 L=1,4 230 DATE1(L,J-1) = DATE1(L,J) 240 DO 250 L=1,3 250 DATE1(L,JJ) = HKL(L) DATE1(4,JJ) = ESUM RETURN 300 IE1 = MAXDAT + 1 - IE1 I = MAXDAT - IE1 + 1 ESUMMA = DATE1(4,I) ESUMMI = DATE1(4,MAXDAT) WRITE (IE100, 410) IE1, ESUMMI, ESUMMA WRITE (LIS2, 410) IE1, ESUMMI, ESUMMA 410 FORMAT (' For ', I3, ' weakest reflections: E1+Eobs+SIG(Eobs) = ', * F4.2, ' upto ', F4.2) DO 430 I=MAXDAT,MAXDAT-IE1+1,-1 WRITE (IE100, 420) (NINT(DATE1(I1,I)), I1=1,3) 420 FORMAT (3I4) 430 CONTINUE WRITE (IE100, FMT='(''END'')') RETURN END SUBROUTINE DIFFT (KEY) 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 SWPRI, EXPAND EQUIVALENCE (SWPRI, SWITCH(10)), (EXPAND, SWITCH(23)) EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IBINDU, IFILE(14)), (IBINDI, IFILE(15)) EQUIVALENCE (IBINFF, IFILE(16)) EQUIVALENCE (NRECYR, KEYS(11)), (NAT, KEYS(17)), (NATL, KEYS(18)) COMMON /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) DIMENSION FITFO(3), FITFC(2), FITFC2(51) EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1)) PARAMETER (MAXBUF = 198) COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV, * SUMX, SUMY, SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2, * NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF, * KEYT, KEYRET, JCODE, SUMF2R, Y, X, XSIG, * ITP, E1, E2, KEYDX, KEYDS, * NITFO, NITFC, NITDUA, NITDIF, NITFFT, * KENDFO, KENDFC, KENDUA, KENDIF, KENDFF, * FITDUA(7), FITDIF(4), FITFFT(5), * BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF) EQUIVALENCE (FITDUA(4), ZSCATT), (FITDUA(5), P1), (FITDUA(6), P2), * (FITDUA(7), W1) EQUIVALENCE (FITDIF(1), HCODI), (FITDIF(2), EL), (FITDIF(3), PL), * (FITDIF(4), WL) DIMENSION NNNN(3) PARAMETER (WMIN = 0.9, EFMIN = 0.5, RAD = 57.29578) LOGICAL LOGDUA, LOGDIF DATA LOGDUA, LOGDIF / .FALSE., .FALSE. / DATA WFIND, WF2, WF3, NPP, SHARP / 1.0, 0.0, 0.0, 0, 0.0 / IF (KEY) 200, 230, 420 200 CALL KERNZI (0, NNNN, 3) SHARP = 0.0 IF (STLMAX .LT. 0.5) THEN SHARP = BR * (0.55 - STLMAX) * 10. IF (SHARP .GT. 20.) SHARP = 20. WRITE (LIS1, 211) STLMAX, BR, SHARP 211 FORMAT(' STLMAX=',F6.4,' BR=',F6.3,' Sharpening: SHARP =',F6.3) ENDIF WFIND = 1.0 IF ((KEYD .EQ. 3 .AND. KEYDS .EQ. 0) .OR. KEYD .EQ. 2) THEN IF (PSQ .GT. .60) WFIND = AMAX1 ((0.90 - PSQ) / 0.30 , 0.) IF (WFIND .LT. .30) WFIND = 0.0 WF3 = (1. - WFIND) * AMAX1 ((PSQ - 0.70) / 0.30, 0.0) WF2 = 1. - WFIND - WF3 ENDIF IF (.NOT. SWPRI .OR. KEYD.EQ.3) RETURN CHOUT = '(5(F6.0, 2F4.0, F6.0, F5.0))' CALL LINPRI (LIS2, FITFFT, 25) NPP = MAX0 (1, (NREFL/200)) WRITE (LIS2, FMT='(/'' DDMAIN listing for '', A6, * '', OPTION: Prepare input for PROGRAM FOUR'')') CCODE WRITE (LIS2, FMT='(''0Print every '',I3,''th- reflection'', * '' (accepted for FOUR)'', /, * '' H K L AMPL PHASE'', /)') NPP RETURN 230 CONTINUE D123 = AMIN1 (0.1 + (1.-PSQ)/4., 0.2) X123 = AMIN1 (0.1 + (1.-PSQ)/0.8, 0.4) WXY= AMAX1 (AMIN1 ((Y / AMAX1(X, 0.01) - D123) / X123, 1.0), 0.0) WX = AMAX1 (AMIN1 ((XSIG/AMAX1(X, 0.01) - 0.2) / 0.15 , 2.0), 0.0) WX = WX * AMIN1 (1.5 - PSQ, 1.0) WXDX = AMIN1 (WX * XSIG, X) WXDY = AMIN1 (WX * XSIG, ABS(X-Y)) IF (X -Y .LT. 0.0) WXDY = - WXDY IF (KEYD.EQ.3 .AND. KEYDS.GE.4) GOTO 321 IF (KEYDX.EQ.3 .OR. LOGDUA) GOTO 270 CALL BINIFF (0, IBINDU, 'BINDUA', FITDUA, NITDUA, BUFDUA, KENDUA) IF (KENDUA.LT.0) THEN LOGDUA = .TRUE. KEYDX = 3 RETURN ENDIF HCODU = FITDUA(1) IF (HCODU-HCODE .GE. 0.99) THEN KEYDX = 3 KENDUA = KENDUA - NITDUA RETURN ENDIF E1 = FITDUA(2) E2 = FITDUA(3) IF (LOGDIF) GOTO 270 CALL BINIFF (0, IBINDI, 'BINDIF', FITDIF, NITDIF, BUFDIF, KENDIF) IF (KENDIF.LT.0) THEN LOGDIF = .TRUE. GOTO 270 ENDIF IF (HCODI-HCODE .GE. 0.99) THEN KENDIF = KENDIF - NITDIF NNNN(2) = NNNN(2) + 1 GOTO 270 ENDIF IF (WL.GE.WMIN .OR. WL.GT.5*W1) GOTO 260 NNNN(1) = NNNN(1) + 1 GOTO 270 260 FL = EL * ZSCATT EF = FL * WL PLRAD = PL / RAD PHIRAD = PHIP / RAD FA = EF * COS(PLRAD) + Y * COS(PHIRAD) FB = EF * SIN(PLRAD) + Y * SIN(PHIRAD) EF = SQRT(FA*FA + FB*FB) PHAMP = ATAN2(FB,FA) * RAD IF (PHAMP.LT.-0.5) PHAMP = PHAMP + 360. GOTO 300 270 EX1 = -0.5 * E1**2 EX2 = -0.5 * E2**2 IF (ITP .NE. 0) GOTO 280 Q = EX1 - EX2 EF = X * SIMW(Q) GOTO 290 280 EX1 = EXP(EX1) EF = X * (2. * EX1 / (EX1+EXP(EX2)) -1.0) 290 EF = WFIND * EF + WF2 * WXY * (X - WXDX + X - Y - WXDY) * + WF3 * WXY * (X - WXDX) IF (PSQ .LE. .95) GOTO 296 IF (KEYS(19) .NE. 4) GOTO 296 IF ( (NAT .EQ. NATL .AND. NRECYR .GE. 4) .OR. * ( NAT .LE. NATL+1 .AND. NRECYR .GE. 5) .OR. NRECYR .GE. 6) THEN XX4 = AMIN1 (X, 4.* Y) YY4 = AMIN1 (Y, 4.* X) EF = 2. * XX4 - YY4 IF (2. * X .LT. XSIG) EF = 0. ENDIF 296 PHAMP = PHIP IF (EF.GT.0.) GOTO 300 EF = -EF PHAMP = PHAMP - 180. IF (PHAMP.LT.-0.5) PHAMP = PHAMP + 360. 300 IF (EF.LT.EFMIN) RETURN NNNN(3) = NNNN(3) + 1 CALL KERNAB (HKLX, FITFFT, 3) FITFFT(4) = EF * EXP (SHARP * STL2) FITFFT(5) = PHAMP IF (.NOT. SWPRI .OR. KEYD.NE.2) GOTO 310 IF (NNNN(3) / NPP*NPP .NE. NNNN(3)) GOTO 310 CALL LINPRI (0, FITFFT, 5) 310 CALL BINOFF (0, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, KENDFF) RETURN 321 EF = WXY * (X - WXDX) IF (KEYDS .EQ. 6) EF = EF + WXY * (X - Y - WXDY) IF (KEYDS .EQ. 5) EF = WXY * (X - Y - WXDY) IF (KEYDS .EQ. 9) EF = Y GOTO 296 420 IF (KEYD.EQ.2) THEN IF (SWPRI) CALL LINPRI (-1, FITFFT, 5) WRITE (LIS2, 430) NNNN(2) 430 FORMAT (/ I6, ' reflections skipped by PHASEX') WRITE (LIS2, 440) NNNN(1), WMIN 440 FORMAT (I6, ' refined reflections with weight < ', F6.4, * ' considered unrefined') ENDIF CALL BINOFF (-1, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, KENDFF) NNNN(2) = NR - NNNN(3) WRITE (LIS2, 445) NNNN(2), EFMIN, NNNN(3) 445 FORMAT ( I6, ' reflections with ampl. < ', F4.2, ', skipped', * / , I6, ' reflections accepted (written to BINFFT file)') RETURN END SUBROUTINE W1PROB (ITYP, A, B, PROB) IF (B.GT.6.0) B = 6.0 IF (A.GE.0.0) GOTO 100 PROB = 1.0 A = -A IF (A.GT.4.0) A = 4.0 RETURN 100 IF (A.LE.4.0) GOTO 110 A = 4.0 B = 4.0 PROB = 0.5 RETURN 110 IF (ITYP.GE.1) GOTO 120 R1 = A*EXP(-A*A) R2 = B*EXP(-B*B) + R1 GOTO 130 120 R1 = EXP(-0.5*A*A) R2 = EXP(-0.5*B*B) + R1 130 PROB = R1 / R2 RETURN END SUBROUTINE DIRESC (PSQ) 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)) PARAMETER (MAXBUF = 198) COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV, * SUMX, SUMY, SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2, * NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF, * KEYT, KEYRET, JCODE, SUMF2R, Y, X, XSIG, * ITP, E1, E2, KEYDX, KEYDS, * NITFO, NITFC, NITDUA, NITDIF, NITFFT, * KENDFO, KENDFC, KENDUA, KENDIF, KENDFF, * FITDUA(7), FITDIF(4), FITFFT(5), * BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF) DIMENSION W1LIM(6), EPLIM(6) DATA W1LIM / .001, .050, .200, .800, .999, 1.000 / DATA EPLIM / .01, .20, .60, 1.00, 1.50, 10.000 / IF (SUMX2 .LT. 0.000001 .OR. SUMX .LT. 0.0001) THEN WRITE (LIS1, FMT='(/'' Emergency wayout: RESCALE bypassed'')') RETURN ENDIF PSQX = SUMY2/SUMX2 SUMXY = SUMXY/SUMX WRITE (LIS1, 200) NR, SUMXY WRITE (LIS2, 200) NR, SUMXY 200 FORMAT (/' R-value on ', I6, ' reflections is R = ', F6.3 ) DO 210 I=1,6 IF (NUMEP(I).LE.0) EPPROC(I) = 0. IF (NUMEP(I).GT.0) EPPROC(I) = * 100. * FLOAT(NUMEP2(I)) / FLOAT(NUMEP(I)) 210 CONTINUE W1PROC = 100. * FLOAT(NUMW1(6)) / NR IF (KEYD .EQ. 1) WRITE (LIS2, 220) (W1LIM(I), NUMW1(I), * EPLIM(I), NUMEP(I), NUMEP2(I), EPPROC(I), I=1,6), W1PROC 220 FORMAT (/' Distribution of reflections in ranges of weight W1', * ' and EP:' / ' W1-interval EP-interval' / * ' W1-lim. No EP-lim. No No(*) Perc(*)' / * ' 0.000-',F5.3, I5, ' 0.00-', F5.2, 2I5, F9.2, * 5 (/ 7X,F5.3, I5, F13.2, 2I5, F9.2) /9X,' * *'/ * 9X, ' *=FP.gt.FO : percentage', F6.2 ) WRITE (LIS2, 230) PSQX 230 FORMAT (' Recalculated scattering power of the known part is', * ' P(av)**2 = ', F6.3, ' (not used)') E2AV = E2SUM / NR RESC = SQRT(E2AV) IF (PSQ .GT. 0.98) RETURN IF (KEYD .NE. 1 ) GOTO 277 IF (RESC.LT..88 .OR. RESC.GT.1.12 .OR. SWITCH(1)) * WRITE (LIS2, 246) E2AV 246 FORMAT (' TEMP ... The average value of Er**2 is', F5.2 ) IF (PSQ .GT. 0.95) GOTO 277 IF (RESC.LT..80 .OR. RESC.GT.1.22) THEN WRITE (LIS1, 247) E2AV 247 FORMAT (' The average value of Er**2 is', F5.2, ' (not used)') WRITE (LIS1, 270) 270 FORMAT (20X, 'This is a rather large deviation' * / 20X, 'Check your input data ...' //) ENDIF 277 IF (RESC.LT..95 .OR. RESC.GT.1.10) GOTO 280 RETURN 280 CONTINUE RESCAL = SQRT (RESC**2 * (1. - PSQ) + PSQ ) WRITE (LIS1, 291) RESCAL WRITE (LIS2, 291) RESCAL 291 FORMAT (' The RESCALE factor to make avg. Er**2 = 1.0 is', F6.3, * ' (not used)' ) RETURN END SUBROUTINE DIPATT (KEY) 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 SWPRI EQUIVALENCE (SWPRI, SWITCH(10)) EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE( 8)) EQUIVALENCE (IBINFF, IFILE(16)) 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 /CRYSB/ SPGR, WAVEAT, CELATY(10) CHARACTER SPGR *16, WAVEAT *2, CELATY *2 COMMON /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) DIMENSION FITFO(3), FITFC(2), FITFC2(51) EQUIVALENCE (HCODE, FITFO(1)), (FP, FITFC(1)), (EPSIL2, FITFC2(1)) PARAMETER (MAXBUF = 198) COMMON /DIFDIF/ KEYD, NREFL, BPINP, BRINP, BPAV, * SUMX, SUMY, SUMX2, SUMY2, SUMXY, SUMFP2, SUMFO2, * NUMEP(6), NUMW1(6), NUMEP2(6), EPPROC(6), E2SUM, NR, IEF, * KEYT, KEYRET, JCODE, SUMF2R, Y, X, XSIG, * ITP, E1, E2, KEYDX, KEYDS, * NITFO, NITFC, NITDUA, NITDIF, NITFFT, * KENDFO, KENDFC, KENDUA, KENDIF, KENDFF, * FITDUA(7), FITDIF(4), FITFFT(5), * BUFDUA(MAXBUF), BUFDIF(MAXBUF), BUFFFT(MAXBUF) DIMENSION NNNN(2), PATX(11) PARAMETER (EFMIN = 0.1, PI02 = 0.6283185) DATA SINGPK, NPP, DEL10 / 0.0, 0, 0.0/ IF (KEY) 200, 230, 260 200 CALL KERNZA (0.0, PATX, 11) CALL KERNZI (0, NNNN, 2) SINGPK = 0.0 WRITE (LIS1, FMT='('' Prepare input for sharpened Patterson'')') WRITE (LIS2, FMT='('' Prepare input for sharpened Patterson'')') IF (KEYDS .NE. 0 . AND. SWITCH(1)) * WRITE (LIS2, FMT='('' TEMP: PATTY without origin removal !'')') IF (.NOT. SWPRI) RETURN DEL10 = 10.0 WRITE (LIS2, FMT='('' DDMAIN listing for '', A6, * '', OPTION: Prepare input for PROGRAM ORIENT'')') CCODE NPP = MAX0 (1, (NREFL/200)) WRITE (LIS2, FMT='('' Print every '',I3,''th- reflection'', * '' (accepted for sharpened Patterson)'', /, * '' H K L AMPL PHASE'')') NPP CHOUT = '(5(F6.0, 2F4.0, F6.0, F5.0))' CALL LINPRI (LIS2, FITFFT, 25) RETURN 230 DDD = (0.2 + STL)**2 * EXP(BP * STL2) EFP = X**2 * DDD IF (KEYDS .EQ. 0) THEN EF = EFP - EXP(-2. * BP * STL2) * SUMF2R * ALATT * DDD ELSE EF = EFP ENDIF SINGPK = SINGPK + EFP XH = 0.0 DELXH = HKLX(1,1) * PI02 / CELL(1) DO 240 I=1,11 PATX(I) = PATX(I) + EFP*COS(XH) 240 XH = XH + DELXH IF (EF.GE.0.0) THEN PHAMP = 0. ELSE PHAMP = 180. EF = -EF ENDIF NNNN(2) = NNNN(2) + 1 IF (EF.LT.EFMIN) RETURN IF (SWPRI .AND. NNNN(2).EQ.1) THEN IF (EF.GT.1000.) DEL10 = 100. WRITE (LIS2, FMT='(''+'',27X,''(AMPL/'',F4.0,'')'',/)') DEL10 ENDIF CALL KERNAB (HKLX, FITFFT, 3) FITFFT(4) = EF FITFFT(5) = PHAMP CALL BINOFF (0, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, KENDFF) IF (.NOT. SWPRI) RETURN IF (NNNN(2)/NPP*NPP .NE. NNNN(2)) RETURN EF = EF / DEL10 CALL LINPRI (0, FITFFT, 5) RETURN 260 IF (SWPRI) CALL LINPRI (-1, FITFFT, 5) CALL BINOFF (-1, IBINFF, 'BINFFT', FITFFT, NITFFT, BUFFFT, KENDFF) SINGPK = SINGPK * 2. * ASYMM / VOLUM SUMAL = 0 DO 265 I=1,NTYPE IF (CELATY(I) .NE. 'H ') SUMAL = SUMAL + CELALL(I) 265 CONTINUE SINGPK = SINGPK / SUMAL PATX1 = PATX(1) * 2. * ASYMM / VOLUM WRITE (LIS1, 270) SCALE, BP 270 FORMAT (' Origin removed sharpened PATTERSON function', / * ' ((', F7.4, '*Fobs)**2 - ORIGIN) * (0.2+STL)**2 * exp(', * F6.3, '*STL2)') WRITE (LIS2, 280) PATX1, SINGPK 280 FORMAT (' Output ORIENT parameters:'/ * ' Patterson origin peak height =', F9.2 / * ' Averaged single peak maximum =', F9.2 ) DO 290 I=2,11 IF (PATX(I) .LT. 0.) PATX(I) = 0. 290 PATX(I) = PATX(I) / PATX(1) PATX(1) = 1.0 WRITE (LIS2, 300) PATX 300 FORMAT (' Patterson peak shape' / * ' xa = 0.0 0.1 0.2 0.3 0.4 0.5 ', * ' 0.6 0.7 0.8 0.9 1.0 A' / * ' P(xa)=', F5.2, 10F6.3 ) NNNN(1) = NNNN(2) - NR NNNN(2) = NR WRITE (LIS2, 310) NNNN(1), EFMIN, NNNN(2) 310 FORMAT (I8, ' Reflections with amplitude <', F5.2, ' skipped', * / I8, ' Reflections accepted (written to BINFFT file)') DO 320 I=2,7 320 IF (PATX(I).LT.0.0) PATX(I) = 0.0 CALL LOGPAT (SINGPK, PATX1, PATX) RETURN END SUBROUTINE LOGPAT (SINGPK, PATX1, PATX) 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 EQUIVALENCE (IDDL, IFILE(1)) DIMENSION PATX(11) WRITE (CHOUT, 200) SINGPK, PATX1 200 FORMAT ('SINGPK', F9.3, ' ORIGIN', F10.2) CALL LOGWR (IDDL) WRITE (CHOUT, 220) (PATX(I), I=2,9) 220 FORMAT ('PK SHAPE', 8F6.3) CALL LOGWR (IDDL) CALL FILCLO (IDDL, 'KEEP') RETURN END SUBROUTINE WISSEN 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 (IE100, IFILE(10)), (IBINFC, IFILE(12)) EQUIVALENCE (IBINDU, IFILE(14)), (IBINDI, IFILE(15)) CALL FILINQ (IBINDU, 'BINDUA', 'UNFORMATTED', 'INPUT', KINQU) IF (KINQU .NE. -1) THEN CALL FILCLO (IBINDU, 'DELETE') ENDIF CALL FILINQ (IBINDI, 'BINDIF', 'UNFORMATTED', 'INPUT', KINQI) IF (KINQI .NE. -1) THEN CALL FILCLO (IBINDI, 'DELETE') ENDIF CALL FILINQ (IE100, 'E100', 'FORMATTED', 'INPUT', KINIE) IF (KINIE .NE. -1) THEN CALL FILCLO (IE100, 'DELETE') ENDIF RETURN END SUBROUTINE WILSIN (KEY) 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 /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 /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) PARAMETER (MAXAT = 993) COMMON / / SICO(12500), FF(500,10), EXPBP(500), EXPBR(500), * SUMF2(500), SUMF2P(500), SFAC(13,10), * ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) COMMON / WILS / NOW(9), NUW(9), AW(9), AAW(9), BW(9), * NOV(7,7), NUV(7,7), VA(7,7), VB(7,7), VC(7,7), * VS(7,7) , FHMN, BPMAX, BPMIN, BRMAX, * BRMIN, BPINP, BRINP, KEYWIL, PSQM, * EPMAX, EPMIN PARAMETER (NRS = 9, NRF = 7) LOGICAL SWIL DATA SWIL / .FALSE. / DATA FNRF1, STLM2, FNRS3 / 0.0, 0.0, 0.0/ IF (SWIL) GOTO 180 SWIL = .TRUE. KEYWIL = KEY EPMIN = 9999. EPMAX =-9999. CALL KERNZI (0 , NOW, NRS) CALL KERNZI (0 , NUW, NRS) CALL KERNZA (0., AW, NRS) CALL KERNZA (0., AAW, NRS) CALL KERNZA (0., BW, NRS) CALL KERNZI (0 , NOV, NRF * NRF) CALL KERNZI (0 , NUV, NRF * NRF) CALL KERNZA (0., VA, NRF * NRF) CALL KERNZA (0., VB, NRF * NRF) CALL KERNZA (0., VC, NRF * NRF) CALL KERNZA (0., VS, NRF * NRF) FHMN = 0. BPINP = BP BRINP = BR FNRF1 = FLOAT(NRF+1) FNRS3 = FLOAT(NRS+1) STLM2 = STLMAX**2 180 CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2) EPSIL = FLOAT(IEPS) TUMF2 = SUMF2(ISS) * EPSIL * ALATT TUMF2P = SUMF2P(ISS) * EPSIL * ALATT TUMF2R = (TUMF2 - TUMF2P) * EXPBR(ISS)**2 K = (STL2/STLM2) * (FNRS3) + 1. IF (K.GT.NRS) K = NRS IF (K.LT.1 .OR. K.GT.NRS) GOTO 190 NOW(K) = NOW(K) + 1 IF (FOBS .LT. 5.*SIG) NUW(K) = NUW(K) + 1 AW(K) = AW(K) + FOBS**2 / TUMF2 AAW(K) = AAW(K) + (FP**2 + TUMF2R) / TUMF2 BW(K) = BW(K) + STL2 190 IF (KEYWIL .EQ. -2) RETURN FPW = FP / EXPBP(ISS) FHMN = FHMN + FPW**2 / TUMF2 EP = FPW / SQRT(TUMF2P) EPMIN = AMIN1 (EPMIN, EP) EPMAX = AMAX1 (EPMAX, EP) IF (ABS(EP).GT.6.) EP = 6.0 K = (STL2/STLM2)**1.5 * FNRF1 L = (1.0 - EXP(-EP*EP)) * FNRF1 IF (ICENT.EQ.2) L = ERFU(EP/1.414) * FNRF1 DO 220 IK=0,1 I = K + IK IF (I.GT.NRF .OR. I.LT.1) GOTO 220 DO 210 IL=0,1 J = L + IL IF (J.GT.NRF .OR. J.LT.1) GOTO 210 VA(I,J) = VA(I,J) + FOBS**2 / TUMF2 VB(I,J) = VB(I,J) + FP**2 / TUMF2 VC(I,J) = VC(I,J) + TUMF2R / TUMF2 VS(I,J) = VS(I,J) + STL2 NOV(I,J) = NOV(I,J) + 1 IF (FOBS .LT. 5.*SIG) NUV(I,J) = NUV(I,J) + 1 210 CONTINUE 220 CONTINUE RETURN END SUBROUTINE WIL2DI (NREFL, IWILP) 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 EQUIVALENCE (LIS2, IFILE(8)) COMMON /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) COMMON / WILS / NOW(9), NUW(9), AW(9), AAW(9), BW(9), * NOV(7,7), NUV(7,7), VA(7,7), VB(7,7), VC(7,7), * VS(7,7) , FHMN, BPMAX, BPMIN, BRMAX, * BRMIN, BPINP, BRINP, KEYWIL, PSQM, * EPMAX, EPMIN BMAXD = 1.0 - AMIN1 (1.0, PSQ) BDMAX = AMIN1 (1.00, 1.5 * BMAXD) CALL WIL2DC (NREFL, NRF, IWILP) WRITE (CHOUT, 200) 200 FORMAT (' Parameters after two-dimensional refinement:') CALL SHOUT2 IF (IWILP.EQ.1) WRITE (CHOUT, 210) 210 FORMAT (' .... not acceptable (see LIS2). Use old parameters:') IF (IWILP.EQ.1) CALL SHOUT2 WRITE (CHOUT, 220) BP, BR, SCALE 220 FORMAT (' Bp = ', F6.3, ' Br = ', F6.3, ' Scale = ', F9.5) CALL SHOUT2 IF (IWILP.EQ.1) RETURN BPMAX = BPINP + BMAXD BPMIN = AMAX1 (BPINP - BMAXD, 0.0) BRMAX = BRINP + BMAXD BRMIN = AMAX1 (BRINP - BMAXD, 0.0) IF (KEYWIL.NE.2 .AND. KEYWIL.NE.0) THEN BP = BPINP BPMAX = BP BPMIN = BP ENDIF IF (KEYWIL.NE.1 .AND. KEYWIL.NE.0) THEN BR = BRINP BRMAX = BR BRMIN = BR ENDIF IF (KEYWIL.EQ.0 .OR. KEYWIL.EQ.1) THEN BRMAX = AMIN1(BRMAX, BRINP+BDMAX) BRMIN = AMAX1(BRMIN, BRINP-BDMAX) ENDIF IF (KEYWIL.EQ.0 .OR. KEYWIL.EQ.2) THEN BPMAX = AMIN1(BPMAX, BPINP+BDMAX) BPMIN = AMAX1(BPMIN, BPINP-BDMAX) ENDIF BD = BP - BR SD = SIGN(1.0,BD) BD = ABS (BD) IF (BP.LE.BPMAX .AND. BP.GE.BPMIN .AND. BD.LE.BDMAX .AND. * BR.LE.BRMAX .AND. BR.GE.BRMIN) RETURN BP = AMIN1(BP,BPMAX) BP = AMAX1(BP,BPMIN) BR = AMIN1(BR,BRMAX) BR = AMAX1(BR,BRMIN) IF (KEYWIL.GE.3) GOTO 230 BD = BP - BR SD = SIGN(1.0,BD) BD = ABS (BD) IF (BD.LT.BDMAX) GOTO 230 FHMN = FHMN / FLOAT(NREFL) IF (KEYWIL.EQ.1) FHMN = 1. IF (KEYWIL.EQ.2) FHMN = 0. BM = BP*FHMN + BR*(1.0-FHMN) BP = BM + SD*(1.0-FHMN)*BDMAX BR = BM - SD*FHMN*BDMAX 230 SCNUM = 0.0 SCDEN = 0.0 DO 240 I=1,NRF DO 240 J=1,NRF IF (NOV(I,J).LT.10) GOTO 240 SCDEN = SCDEN + VA(I,J) X = (BP-BPINP) * VS(I,J) Y = (BR-BRINP) * VS(I,J) IF (X.GT.50.) X = 50. IF (Y.GT.50.) Y = 50. SCNUM = SCNUM + VB(I,J)*EXP(-X) + VC(I,J)*EXP(-Y) 240 CONTINUE SCALE = SQRT (SCNUM/SCDEN) WRITE (CHOUT, 250) 250 FORMAT (' Resetting of scale and temperature factors required,', * ' new values are:') CALL SHOUT2 WRITE (CHOUT, 220) BP, BR, SCALE CALL SHOUT2 RETURN END SUBROUTINE WIL2DC (NREFL, NRF, IWILP) 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 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 (SWIPRI, SWITCH(10)) EQUIVALENCE (LIS1, IFILE(7)), (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 /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) COMMON / WILS / NOW(9), NUW(9), AW(9), AAW(9), BW(9), * NOV(7,7), NUV(7,7), VA(7,7), VB(7,7), VC(7,7), * VS(7,7) , FHMN, BPMAX, BPMIN, BRMAX, * BRMIN, BPINP, BRINP, KEYWIL, PSQM, * EPMAX, EPMIN DIMENSION IY(9), STLRAN(8), EPRAN1(2,7), EPRAN2(2,7), EPRANG(2,7) DIMENSION D(3,7,7), AMAT(3,3), AMATIN(3,3), V(3), SH(3), * ERR(3), PA(3), AC(7,7) EQUIVALENCE (SC, PA(1)) DIMENSION NPERCA(7), NPERCU(7), PERCU(7) CHARACTER *8 VARI(3) DATA VARI / ' K', 'delta BP', 'delta BR' / DATA EPRAN1 / 0.00, 0.53, 0.36, 0.68, 0.54, 0.83, 0.69, 0.99, * 0.84, 1.17, 1.00, 1.44, 1.18, 4.26 / DATA EPRAN2 / 0.00, 0.31, 0.15, 0.48, 0.32, 0.67, 0.49, 0.88, * 0.68, 1.15, 0.89, 1.53, 1.16, 3.50 / DATA PSC /0.0/ NRF = 7 IF (NREFL.GT.400) GOTO 190 K = 0 DO 170 I=1, (NRF-1), 2 K = K + 1 IJ = 0 DO 170 J=1, (NRF-1), 2 IJ = IJ + 1 NOV(IJ,K) = NOV(J,I) + NOV(J+1,I) + NOV(J,I+1) + NOV(J+1,I+1) NUV(IJ,K) = NUV(J,I) + NUV(J+1,I) + NUV(J,I+1) + NUV(J+1,I+1) VA(IJ,K) = VA(J,I) + VA(J+1,I) + VA(J,I+1) + VA(J+1,I+1) VB(IJ,K) = VB(J,I) + VB(J+1,I) + VB(J,I+1) + VB(J+1,I+1) VC(IJ,K) = VC(J,I) + VC(J+1,I) + VC(J,I+1) + VC(J+1,I+1) 170 VS(IJ,K) = VS(J,I) + VS(J+1,I) + VS(J,I+1) + VS(J+1,I+1) IJ = 0 DO 180 I=1, (NRF-1), 2 IJ = IJ + 1 NOV(IJ,K) = NOV(IJ,K) + NOV(I,NRF) + NOV(I+1,NRF) NOV(K,IJ) = NOV(K,IJ) + NOV(NRF,I) + NOV(NRF,I+1) NUV(IJ,K) = NUV(IJ,K) + NUV(I,NRF) + NUV(I+1,NRF) NUV(K,IJ) = NUV(K,IJ) + NUV(NRF,I) + NUV(NRF,I+1) VA(IJ,K) = VA(IJ,K) + VA(I,NRF) + VA(I+1,NRF) VA(K,IJ) = VA(K,IJ) + VA(NRF,I) + VA(NRF,I+1) VB(IJ,K) = VB(IJ,K) + VB(I,NRF) + VB(I+1,NRF) VB(K,IJ) = VB(K,IJ) + VB(NRF,I) + VB(NRF,I+1) VC(IJ,K) = VC(IJ,K) + VC(I,NRF) + VC(I+1,NRF) VC(K,IJ) = VC(K,IJ) + VC(NRF,I) + VC(NRF,I+1) VS(IJ,K) = VS(IJ,K) + VS(I,NRF) + VS(I+1,NRF) 180 VS(K,IJ) = VS(K,IJ) + VS(NRF,I) + VS(NRF,I+1) NOV(K,K) = NOV(K,K) + NOV(NRF,NRF) NUV(K,K) = NUV(K,K) + NUV(NRF,NRF) VA(K,K) = VA(K,K) + VA(NRF,NRF) VB(K,K) = VB(K,K) + VB(NRF,NRF) VC(K,K) = VC(K,K) + VC(NRF,NRF) VS(K,K) = VS(K,K) + VS(NRF,NRF) NRF = K 190 WRITE (LIS2, 200) 200 FORMAT ('0Two-dimensional refinement of BP and BR', /, * ' Distribution of reflections (and unobs.) in array') FNRF1 = FLOAT(NRF+1) F13 = 1. / 3. DO 205 I=1,NRF 205 STLRAN(I) = STLMAX * (FLOAT(I)/FNRF1)**F13 STLRAN(NRF+1) = STLMAX CALL KERNZI (0, NPERCU, NRF) CALL KERNZI (1, NPERCA, NRF) DO 207 I = 1, NRF DO 207 J = 1, NRF NPERCA(I) = NPERCA(I) + NOV(I,J) 207 NPERCU(I) = NPERCU(I) + NUV(I,J) PERCUM = 0.0 DO 208 I = 1, NRF PERCU(I) = 100. * FLOAT(NPERCU(I)) / FLOAT(NPERCA(I)) IF (PERCU(I) .GT. PERCUM) PERCUM = PERCU(I) 208 CONTINUE IF (PERCUM .LE. 30.) GOTO 214 WRITE (LIS1, 210) STLRAN(2), (STLRAN(I), STLRAN(I+2), I=1,NRF-1) WRITE (LIS2, 210) STLRAN(2), (STLRAN(I), STLRAN(I+2), I=1,NRF-1) 210 FORMAT (/' sinTH/L range: 0.0-', F3.2, 6(1X, F3.2,'-', F3.2), * 1X, F3.2,'-', F4.2 ) WRITE (LIS1, 212) (PERCU(I), I = 1, NRF) WRITE (LIS2, 212) (PERCU(I), I = 1, NRF) 212 FORMAT (' Percentage unobs:', 7(F6.0,2X)) 214 WRITE (LIS2, 210) STLRAN(2), (STLRAN(I), STLRAN(I+2), I=1,NRF-1) CALL KERNAB (EPRAN1, EPRANG, 14) IF (ICENT .EQ. 2) CALL KERNAB (EPRAN2, EPRANG, 14) EPRANG(1,1) = AMAX1 (EPRANG(1,1), EPMIN) EPRANG(2,NRF) = AMIN1 (EPRANG(2,NRF), EPMAX) WRITE (LIS2, 220) 220 FORMAT (' Ep range=') DO 260 J=1,NRF WRITE (LIS2, 230) (EPRANG(I2,J),I2=1,2), (NOV(I,J), I=1,NRF) 230 FORMAT ('0', F4.2, '-', F4.2, ' All ', 7I8) WRITE (LIS2, 240) (NUV(I,J), I=1,NRF) 240 FORMAT (10X, 'Unobs ', 7I8) DO 260 I=1,NRF XN = NOV(I,J) IF (XN.LT.1.0) XN = 1.0 IF (NOV(I,J).GT.10) GOTO 250 NOV(I,J) = 0 NUV(I,J) = 0 VA(I,J) = 0.0 AC(I,J) = 0.0 VB(I,J) = 0.0 VC(I,J) = 0.0 VS(I,J) = 0.0 GOTO 260 250 VA(I,J) = VA(I,J) / XN VB(I,J) = VB(I,J) / XN VC(I,J) = VC(I,J) / XN VS(I,J) = VS(I,J) / XN * 2.0 260 CONTINUE KEYNRS = 0 270 KEYNRS = KEYNRS + 1 SC = 1.0 / SCALE**2 PA(2) = 0 PA(3) = 0 NY = 0 IWILP = 0 DO 290 J=1,NRF NX = 0 IY(J) = 0 DO 280 I=1,NRF NX = NX + NOV(I,J) 280 CONTINUE IF (NX.EQ.0) GOTO 290 NY = NY + 1 IY(NY) = J 290 CONTINUE IF (NY.GT.2) GOTO 330 IF (NY.EQ.2) GOTO 320 300 IWILP = 1 WRITE (LIS2, 310) 310 FORMAT (' Refining scale and temperature factors seperately' / * ' is impossible for this problem: use old parameters.') RETURN 320 IF ((IY(2)-IY(1)) .EQ. 1) GOTO 300 330 SIG = 10000.0 WRITE (LIS2, FMT='('' Input values for two-dimensional'', * '' refinement: scale = '', F9.5 ,/, 48X,'' Bp ='', F7.3, * '' Br ='', F7.3)') SCALE, BPINP, BRINP IF (SWIPRI) WRITE (LIS2, 340) 340 FORMAT (' Note: K = 1/SCALE**2') NCYC = 10 NP = 3 PCYMAX = 1.2 DO 490 NC=1,NCYC SIGOLD = SIG SIG = 0.0 CALL KERNZA (0., AMAT, 9) CALL KERNZA (0., V, 3) DO 370 I=1,NRF DO 370 J=1,NRF IF (NOV(I,J).EQ.0) GOTO 370 P = EXP (-PA(2)*VS(I,J)) Q = EXP (-PA(3)*VS(I,J)) D(1,I,J) = VB(I,J)*P + VC(I,J)*Q D(2,I,J) = -VB(I,J) * VS(I,J) * P * SC D(3,I,J) = -VC(I,J) * VS(I,J) * Q * SC AC(I,J) = VA(I,J) - SC*D(1,I,J) XN = 100.0 / NOV(I,J) IF (XN.LT.1.0) XN = 1.0 DO 360 K=1,NP DO 350 L=1,NP 350 AMAT(K,L) = AMAT(K,L) + D(K,I,J)*D(L,I,J)/XN V(K) = V(K) + D(K,I,J)*AC(I,J)/XN SIG = SIG + AC(I,J)**2/XN 360 CONTINUE 370 CONTINUE SIG = SQRT (SIG / (NRF*NRF-NP)) IF (SWIPRI) WRITE (LIS2, 380) NC, SIG 380 FORMAT (' Cycle', I2, ' Sigma =', G12.4) CALL MATINV (AMAT, AMATIN, DMAT, KEND) IF (DMAT .LT. 10.E-9) WRITE (LIS2, 381) 381 FORMAT (' Warning: small determinant, results unreliable?') IF (KEND.EQ.-99) GOTO 545 DO 390 I=1,NP SH(I) = 0.0 ERR(I) = SQRT (AMATIN(I,I)) DO 390 J=1,NP 390 SH(I) = SH(I) + AMATIN(I,J)*V(J) DO 400 I=1,NP DO 400 J=1,NP 400 AMATIN(I,J) = AMATIN(I,J) / (ERR(I) * ERR(J)) DO 410 I=1,NP 410 ERR(I) = ERR(I) * SIG IF (SWIPRI) WRITE (LIS2, 420) 420 FORMAT (30X, ' Par', 5X, 'Old', 5X, 'Shift', 5X, 'New',5X,'Error') DO 470 J=1,3 P = SH(J) IF (NC.LE.3) P = P * .9 IF (J.EQ.1) GOTO 430 IF (P.GT.PCYMAX) P = PCYMAX IF (P.LT.-PCYMAX) P = -PCYMAX 430 X = PA(J) + P IF (J .EQ. 1) X = AMAX1 (X, PA(1) / 5.) IF (SWIPRI) WRITE (LIS2, 450) VARI(J), PA(J), SH(J), X, ERR(J) 450 FORMAT (27X, A8, 4F9.4) PA(J) = X IF (J.GT.1) GOTO 470 PSC = 1. / SQRT(ABS(X)) IF (SWIPRI) WRITE (LIS2, 460) PSC 460 FORMAT (1H+, 8X, 'SC(new) =', F7.4) 470 CONTINUE IF (.NOT. SWIPRI) * WRITE (LIS2, 480) NC, BPINP+PA(2), BRINP+PA(3), PSC 480 FORMAT (' Cycle', I2, ' New Bp =', F7.3, ' Bp =', F7.3, * ' SCALE =', F10.5 ) IF (NC.LT.4) GOTO 490 IF (ABS(SIGOLD-SIG).LT.0.01*SIG) GOTO 590 IF (SIG.GT.1.5*SIGOLD) GOTO 550 IF ((PA(2)+BPINP).LT.-5. .OR. (PA(2)+BPINP).GT.30. .OR. * (PA(3)+BRINP).LT.-5. .OR. (PA(3)+BRINP).GT.30.) GOTO 530 IF (SC.LT.0.0000001) GOTO 530 490 PCYMAX = PCYMAX + .15 WRITE (LIS2, 500) NCYC 500 FORMAT (' Series is still unconverged after', I3, ' cycles') GOTO 570 530 WRITE (LIS2, 540) 540 FORMAT (' Unreasonable results' ) GOTO 570 545 WRITE (LIS2, 546) 546 FORMAT (' Determinant is zero: no 2-dimens. Bp Br Sc ref. plot ') GOTO 570 550 WRITE (LIS2, 560) 560 FORMAT (' Series is diverging seriously') 570 IWILP = 1 IF (KEYNRS.GT.1 .OR. NRF.LE.6) GOTO 610 WRITE (LIS2, 580) 580 FORMAT (' Try again; skip high order refl.') NRF = NRF-2 GOTO 270 590 WRITE (LIS2, 595) NC 595 FORMAT (' Series has converged after', I3, ' cycles') IF (KEYNRS.GT.1 .OR. NRF.LE.6) GOTO 610 IF (ABS(PA(2)) .LT. 2.5) GOTO 610 WRITE (LIS2, 600) 600 FORMAT (' A large change of BP, too large.') GOTO 570 610 IF (IWILP.GT.0) RETURN IF (SWIPRI) * WRITE (LIS2, 620) VARI, (VARI(I), (AMATIN(I,J), J=1,NP), I=1,NP) 620 FORMAT (' Correlation matrix',12X,A8,4X,A8,2X,A8 /(22X,A8,3F10.4)) SCALE = 1.0 / SQRT(SC) BP = PA(2) + BPINP BR = PA(3) + BRINP RETURN END SUBROUTINE MERBIN 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 EQUIVALENCE (IDDL, IFILE(1)), (IPR1, IFILE(6)) EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IBINFO, IFILE(11)), (IBINS, 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 /CRYSB/ SPGR, WAVEAT, CELATY(10) CHARACTER SPGR *16, WAVEAT *2, CELATY *2 COMMON /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) COMMON / WILS / NOW(9), NUW(9), AW(9), AAW(9), BW(9), * NOV(7,7), NUV(7,7), VA(7,7), VB(7,7), VC(7,7), * VS(7,7) , FHMN, BPMAX, BPMIN, BRMAX, * BRMIN, BPINP, BRINP, KEYWIL, PSQM, * EPMAX, EPMIN DIMENSION FITFO(3) EQUIVALENCE (HCODE, FITFO(1)) DIMENSION HKL(3) EQUIVALENCE (HKL(1), HKLX(1,1)) PARAMETER (MAXAT = 993) COMMON / / SICO(12500), FF(500,10), EXPBP(500), EXPBR(500), * SUMF2(500), SUMF2P(500), SFAC(13,10), * ATXYZ (10, MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) DIMENSION HMAX(3), HMIN(3), HCON(3) PARAMETER (MAXBUF = 198) PARAMETER (MAXA = 10000, AMAX = 10000.) COMMON /BUFREF/ BUFS(MAXBUF), BUFFO(MAXBUF), AREF(4, MAXA) LOGICAL FRIE DIMENSION ITEMP(9) DATA FRIE /.TRUE./ DATA IREF /0/ WRITE (LIS1, FMT = '('' First MERBIN use as subroutine: 1997'')') CALL KERNZA ( 9999., HCON, 3) CALL KERNZA ( 9999., HMIN, 3) CALL KERNZA ( -9999., HMAX, 3) STLCON = 9999.9 HKMAX = 0.0 HCODMI = 4.0 * 256.**3 HCODMA = - HCODMI IF (STLMAX .GT. 0.0001) STLCON = STLMAX DO 230 I=1,3 IF (HKLMAX(I) .GT. 0.1) HCON(I) = HKLMAX(I) 230 CONTINUE NIT = 3 CALL BINOFF (4, IBINS, 'BINS', FITFO, NIT, BUFS, KENDS) NREF = 0 MREF = 0 MREF99 = 0 240 CALL MEREAD (HKL, JC, FOBS, SIG, IEND) IF (IEND .LT. 0) GOTO 270 MREF = MREF + 1 CALL HKLAXT (HKL, KEND) IF (KEND.LT.0) GOTO 240 CALL HKLEXT (HKL, KEND) IF (KEND.LT.0) GOTO 240 IF (ABS(HKL(1)).GT.HCON(1) .OR. ABS(HKL(2)).GT.HCON(2) .OR. * ABS(HKL(3)).GT.HCON(3)) GOTO 240 CALL HKLSTL (HKL, STL, STL2) IF (STL .GT. STLCON) GOTO 240 MREF99 = MREF99 + 1 IF (ABS (HKL(1)) .GT. 99. .OR. ABS (HKL(2)) .GT. 99. .OR. * ABS (HKL(3)) .GT. 99. ) GOTO 240 STLMAX = AMAX1 (STLMAX, STL) NREF = NREF + 1 CALL HKLEXS (FRIE, HKL, HCODE) FOBS = AMAX1 (FOBS, 0.01) SIG = AMAX1 (SIG, FOBS / 100. , 0.01) IF (JC .EQ. 2) SIG = AMAX1(FOBS/6.0, SIG) CALL WRPEAK(0, 0., HKLMAX) SIG = SIG * 2. * FOBS FOBS = FOBS ** 2 HCODMI = AMIN1(HCODMI, HCODE) HCODMA = AMAX1(HCODMA, HCODE) CALL HKLC1U (HCODE, HKL) DO 260 I =1,3 HMAX(I) = AMAX1 (HKL(I),HMAX(I)) 260 HMIN(I) = AMIN1 (HKL(I),HMIN(I)) HKMAX = AMAX1 (HKMAX, ABS(HKL(1)+HKL(2)) ) CALL BINOFF (0, IBINS, 'BINS', FITFO, NIT, BUFS, KENDS) GOTO 240 270 CALL BINOFF (-1, IBINS, 'BINS', FITFO, NIT, BUFS, KENDS) CALL KERNZA (0., ATXYZ, 10) IZAT(1) = 1 STLMAX = STLMAX + 0.00001 CALL FCALCI (1, ATXYZ, IZAT, ITAT, 1) DO 280 I=1,3 280 HKLMAX(I) = AMAX1 (ABS(HMAX(I)), ABS(HMIN(I)) ) IF (ISYST.LE.3) GOTO 290 IF (ISYST.EQ.6 .OR. ISYST.EQ.7) * HKLMAX(1) = AMAX1 (HKLMAX(1), HKMAX) IF (ISYST.EQ.5 .OR. ISYST.EQ.8) * HKLMAX(1) = AMAX1 (HKLMAX(1), HKLMAX(3)) HKLMAX(1) = AMAX1 (HKLMAX(1),HKLMAX(2)) HKLMAX(2) = HKLMAX(1) IF (ISYST.EQ.5 .OR. ISYST.EQ.8) HKLMAX(3) = HKLMAX(1) 290 WRITE (LIS1, 292) MREF WRITE (LIS2, 292) MREF 292 FORMAT (' Number of input reflections: ', I17) IF (MREF-NREF .GT. 0) WRITE (LIS1, 294) NREF IF (MREF-NREF .GT. 0) WRITE (LIS2, 294) NREF 294 FORMAT (' Number of relections accepted: ', I17) MREF99 = MREF99 - NREF IF (MREF99 .GT. 0) WRITE (IPR1, 295) MREF99 IF (MREF99 .GT. 0) WRITE (LIS1, 295) MREF99 295 FORMAT (' Number of relections with hkl exceeding 99: ', I7/ * ' WARNING: these reflections are not used in DIRDIF !'/) CALL KERF2I (HMAX, ITEMP, 3) CALL KERF2I (HMIN, ITEMP(4), 3) CALL KERF2I (HKLMAX, ITEMP(7), 3) WRITE (LIS1, 300) ITEMP, STLMAX WRITE (LIS2, 300) ITEMP, STLMAX 300 FORMAT (10X, ' Maximum indices output: ', 3I5 / * 10X, ' Minimum indices output: ', 3I5 / * 10X, ' HKLmax incl. symmetry: ', 3I5 / * 10X, ' Maximum sin(TH/LAMBDA): ', F15.5 ) IF (KEYS(13) .LE. 0) KEYS(13) = 1 FRIEDE = - KEYS(13) BUFFO(5) = FRIEDE BUFFO(6) = STLMAX CALL KERNAB (HKLMAX, BUFFO(7), 3) CALL KERNAB (HMAX, BUFFO(10), 3) CALL KERNAB (HMIN, BUFFO(13), 3) SUMRN1 = 0. SUMRN2 = 0. NSUMR = 0 CALL BINOFF (15, IBINFO, 'BINFO', FITFO, NIT, BUFFO, KENDFO) CALL BINIFF (4, IBINS, 'BINS', FITFO, NIT, BUFS, NENDI) CALL HKLC2I (HMIN, HMAX) CALL HKLC1U (HCODMI, HKL) CALL HKLC2 (HKL, ACODMI) 310 AF = ACODMI - 1.1 CALL HKLC2U (ACODMI + AMAX - 1., HKL) CALL HKLC1 (HKL, HCODEL) CALL KERNZA (0.0, AREF, 4 * MAXA) 320 CALL BINIFF (0, IBINS, 'BINS', FITFO, NIT, BUFS, NENDI) IF (NENDI.LT.0) GOTO 330 IF (HCODE.LT.HCODMI .OR. HCODE.GT.HCODEL) GOTO 320 CALL HKLC1U (HCODE, HKL) CALL HKLC2 (HKL, ACODE) IA = IFIX (ACODE - AF) AREF(1,IA) = AREF(1,IA) + 1. IF (NINT(AREF(1,IA)) .EQ. 2) THEN SUMRN1 = SUMRN1 + ABS(AREF(3,IA)-FOBS) SUMRN2 = SUMRN2 + AREF(3,IA)+FOBS NSUMR = NSUMR + 1 ENDIF AREF(2,IA) = HCODE AREF(3,IA) = AREF(3,IA) + FOBS AREF(4,IA) = AREF(4,IA) + SIG GOTO 320 330 DO 340 I = 1,MAXA IF (AREF(1,I).LE.0.1) GOTO 340 TOT = AREF(1,I) HCODE = AREF(2,I) FOBS = AREF(3,I) / TOT SIG = AREF(4,I) / TOT **1.5 FOBS = SQRT(FOBS) SIG = SIG / (2. * FOBS) CALL BINOFF (0, IBINFO, 'BINFO', FITFO, NIT, BUFFO, KENDFO) IREF = IREF + 1 CALL HKLC1U (HCODE, HKL) CALL HKLSTL (HKL, STL, STL2) CALL WILSIM 340 CONTINUE IF (HCODEL.GE.HCODMA) GOTO 350 ACODMI = ACODMI + AMAX CALL HKLC2U (ACODMI, HKL) CALL HKLC1 (HKL, HCODMI) CALL BINIFF (4, IBINS, 'BINS', FITFO, NIT, BUFS, NENDI) GOTO 310 350 CALL BINOFF (-1, IBINFO, 'BINFO', FITFO, NIT, BUFFO, KENDFO) WRITE (CHOUT, 360) IREF 360 FORMAT (' Number of reflections (merged) output: ' , I7) IF (IREF .LE. 0) CALL KERROR ('Number of refl. = 0',0,'MERBIN') CALL SHOUT IF (NSUMR .GT. 10) THEN SUMRN1 = SUMRN1 / SUMRN2 WRITE (CHOUT, 401) NSUMR, SUMRN1 401 FORMAT (' R-merge (on F**2) for',I5,' reflections is R=',F6.2) CALL SHOUT2 ENDIF WRITE (LIS2,490) 490 FORMAT (/' Least squares Wilson plot' / * ' Range Sin(Th/Lambda)**2 Number <|Fobs|**2/F2>' ) STLM2 = STLMAX**2 / 9. NOWT = 0 DO 560 I=1,9 NOWT = NOW(I) + NOWT STMIN= FLOAT(I-1) * STLM2 STMAX= FLOAT(I) * STLM2 AWNOW = 0. IF (NOW(I) .GT. 0) AWNOW = AW(I)/NOW(I) WRITE(LIS2,550) I, STMIN, STMAX, NOW(I), AWNOW 550 FORMAT(I5,F10.4,' - ',F6.4,I10,F14.6) 560 CONTINUE WRITE(LIS2,570) NOWT 570 FORMAT(' Total number of reflections:', I5) CALL WILPAR (IWILP) CALL LOGMER (NREF, HMAX, HMIN, HKLMAX, STLMAX, SCALE, BP) IF (NREF .GT. 0) CALL WRPEAK(IREF, BP, HKLMAX) CALL FILCLO (IBINS, 'DELETE') CALL FILCLO (IDDL, 'KEEP') WRITE (LIS2, 603) 603 FORMAT( /' ==== END OF SUB-PROGRAM MERBIN ==== '//) RETURN END SUBROUTINE MEREAD (HKL, JC, FOBS, SIG, IEND) DIMENSION HKL(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 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)), (IPR1, IFILE(6)), (LIS1, IFILE(7)) EQUIVALENCE (ICRIN,IFILE(4)), (IHKL,IFILE(11)), (ISHEL,IFILE(12)) EQUIVALENCE (IBINS, IFILE(13)) DIMENSION HH(3,3), JJ(3), FF(3), SS(3), HT(3) CHARACTER IE *1 CHARACTER *6 XHKL(9) CHARACTER *80 CHINA LOGICAL FIRST, F2, TRANS DATA FIRST, F2 , TRANS / .FALSE., .FALSE., .FALSE. / DATA XHKL / 'FREFB', 'FREFC', 'FREFA', 'FREF', 'CARD3', * 'SHELX', 'HKL' , 'CIF' , 'SHELXL' / DATA ICARD / 3 / DATA IDNUM / 0 / IF (FIRST) GOTO 310 FIRST = .TRUE. DO 110 ID = 1, 9 CALL FILINQ (IHKL, XHKL(ID), 'FORMATTED', 'INPUT', KINQ) IF (KINQ .EQ. 0) GOTO 120 110 CONTINUE CALL FILCLO (IBINS, 'DELETE') CALL KERROR ('No reflection file found', 0, 'MERBIN') 119 CALL FILCLO (IBINS, 'DELETE') CALL KERROR(' Empty IHKL file', 119, 'MEREAD') 120 IF (ID .EQ. 8) GOTO 180 IDNUM = 1 CHIN = ' ' READ (IHKL, FMT='(A28)', END=119) CHIN(1:28) WRITE (LIS1, 140) XHKL(ID), CHIN(1:28) 140 FORMAT (' Input data file: ', A6, ' Header: ', A28) CALL KERINB (LIT, 1) IF (ID .GE. 6) GOTO 145 IF ( (ID .EQ. 5 .AND. LIT(1) .NE. 'CARD3' ) .OR. * (ID .LE. 3 .AND. LIT(1)(1:4) .NE. 'FREF') ) THEN CALL FILCLO (IBINS, 'DELETE') CALL KERROR ('File name and header inconsistent' , 0, 'MERBIN') ENDIF IF (ID .NE. 4 .AND. LIT(2) .NE. CCODE) THEN CALL FILCLO (IBINS, 'DELETE') CALL KERROR ('Input file has incorrect CCODE', -6, 'MERBIN') ENDIF IF (ID .EQ. 5) IDNUM = 2 GOTO 310 145 IDNUM = 3 INUM = 0 IHKLF = 0 CHINA = CHIN IF (LIT(1) .EQ. ' ') THEN BACKSPACE IHKL GOTO 148 ELSE IF (CHIN(1:4) .NE. 'HKLF') THEN CALL FILCLO (IBINS, 'DELETE') CALL FILCLO (IHKL, 'KEEP') CALL KERROR ('Incorrect header record', 167, 'MEREAD') ENDIF ENDIF KINS = -1 CALL KERINB (LIT, 1) INUM = NINT(FNUM(1)) IHKLF = 1 GOTO 152 148 CONTINUE CALL FILINQ (ISHEL, 'INS', 'FORMATTED', 'INPUT', KINS) IF (KINS .EQ. 0) GOTO 151 CALL FILINQ (ISHEL, 'RES', 'FORMATTED', 'INPUT', KINS) IF (KINS .NE. 0) GOTO 152 151 READ (ISHEL, END = 1152, FMT = '(A80)') CHIN IF (CHIN(1:4) .EQ. 'HKLF') THEN CALL FILCLO (ISHEL, 'KEEP') CALL KERINB (LIT, 1) INUM = NINT(FNUM(1)) IHKLF = 2 GOTO 1152 ENDIF GOTO 151 1152 CALL FILCLO (ISHEL, 'KEEP') 152 CONTINUE CALL FILCLO (ICRIN, 'KEEP') CALL FILINQ (ICRIN, 'CRYSIN', 'FORMATTED', 'INPUT', KINCR) IF (KINCR .NE. 0) THEN CHOUT = ' CRYSIN file not found: rerun CRYSDA !' CALL SHOUT GOTO 1155 ENDIF 153 READ (ICRIN, END = 1155, FMT = '(A80)') CHIN IF (CHIN(1:4) .EQ. 'HKLF') THEN CALL FILCLO (ICRIN, 'KEEP') CALL KERINB (LIT, 1) INUMX = NINT(FNUM(1)) IF (IHKLF .GT. 0 .AND. INUM .NE. INUMX) THEN CHOUT = ' HKLF on CRYSIN incorrect / discarded ' CALL SHOUT ELSEIF (INUM .EQ. 0) THEN INUM = INUMX IHKLF = 3 ELSE IHKLF = 3 ENDIF GOTO 1155 ENDIF GOTO 153 1155 CALL FILCLO (ICRIN, 'KEEP') IF (INUM .NE. 0 .AND. IHKLF .GT. 0) GOTO 156 155 WRITE (IPR1,FMT= ' * ('' The reflection file may contain F or F**2 values:''/ * '' does your file have F**2 values ? (Y / N)'')') CALL KETERM (0, 1, KEND) IF (KEND .LT. 0) GOTO 155 IF (LIT(1) .NE. 'N' .AND. LIT(1) .NE. 'Y') GOTO 155 IF (LIT(1) .EQ. 'Y') F2 = .TRUE. CHIN = CHINA INUM = 3 IF ( F2 ) INUM = 4 IHKLF = 4 156 IF (IABS (INUM) .NE. 3 .AND. IABS (INUM) .NE. 4) THEN WRITE (CHOUT, FMT='('' input: HKLF'', I3, '' ??'')') INUM CALL SHOUT GOTO 155 ENDIF IF (KINCR .NE. 0 .OR. IHKLF .EQ. 3) GOTO 163 CALL FILINQ (ICRIN, 'CRYSIN', 'FORMATTED', 'OUTPUT', KINCR) CALL FILINQ (ISHEL, 'PAULTB', 'FORMATTED', 'SCRATCH', IIIII) 157 READ (ICRIN, END = 158, FMT = '(A80)') CHIN IF (CHIN(1:4) .EQ. 'HKLF') GOTO 157 WRITE (ISHEL, FMT = '(A80)') CHIN IF (CHIN(1:4) .EQ. 'END ') GOTO 158 GOTO 157 158 REWIND ICRIN REWIND ISHEL 1157 READ (ISHEL, END = 1158, FMT = '(A80)') CHIN IF (CHIN(1:4) .EQ. 'END ') GOTO 1158 WRITE (ICRIN, FMT = '(A80)') CHIN GOTO 1157 1158 WRITE (ICRIN, FMT='(''HKLF'', I4 / ''END'' )') INUM WRITE (CHOUT, FMT='('' HKLF'', I3, * '' : written to the CRYSIN file'')') INUM CALL SHOUT CALL FILCLO (ICRIN, 'KEEP') CALL FILCLO (ISHEL, 'DELETE') 163 INUM = IABS (INUM) WRITE (CHOUT, 162) INUM 162 FORMAT ('HKLF', I4, ' .. HKLF number for SHELX data file') CALL LOGWR (IDDL) IF (INUM.EQ.3) THEN WRITE (LIS1, 165) 165 FORMAT(' Input SHELXL or HKL file: SHELX format (Fobs values)') ELSEIF (INUM.EQ.4) THEN WRITE (LIS1, FMT= * '('' Input SHELXL or HKL file with Fobs**2 values '')') F2 = .TRUE. ELSE CALL FILCLO (IBINS, 'DELETE') CALL KERROR ('Unknown contents of SHELXL or HKL file ...', 165, * 'MEREAD') ENDIF IF (NFNUM .GE. 11) THEN TRANS = .TRUE. DO 175 I = 1, 3 DO 175 J = 1, 3 175 HH(I,J) = FNUM(3*I + J -1) ENDIF GOTO 310 180 IDNUM = 4 190 CALL KERINA( IHKL, LIT(32),1, KEND) IF (KEND .NE. 0) THEN CALL FILCLO (IBINS, 'DELETE') CALL KERROR ('Incorrect CIF file', 190, 'MEREAD') ENDIF IF (CHIN(1:5) .EQ. 'data_') THEN IF (CHIN(6:11) .NE. CCODE) WRITE(LIS1, FMT= * '('' Warning: input CIF file has incorrect CCODE'')') GOTO 190 ENDIF IF (CHIN(1:13) .EQ.'_refln_F_calc') THEN WRITE(LIS1, FMT='('' Input CIF file with Fobs values '')') GOTO 190 ENDIF IF (CHIN(1:21) .EQ.'_refln_F_squared_calc') THEN WRITE(LIS1, FMT='('' Input CIF file with Fobs**2 values '')') F2 = .TRUE. GOTO 190 ENDIF IF (CHIN(1:21) .EQ.'_refln_intensity_calc') THEN CALL FILCLO (IBINS, 'DELETE') CALL KERROR ('CIF file with intensities', 190, 'MEREAD') ENDIF IF (CHIN(1:23) .NE.'_refln_scale_group_code') GOTO 190 310 IEND = 0 GOTO (410, 420, 430, 440), IDNUM 410 READ (IHKL, 415, END=418) IE, HKL, JC, FOBS, SIG 415 FORMAT (A1, 3F3.0 ,I2, F9.2, F7.2) IF (IE .NE. 'E') RETURN 417 CALL FILCLO (IHKL, 'KEEP') IEND = -1 RETURN 418 CHOUT = ' Warning: sentinel E missing on FREF file !' CALL SHOUT GOTO 417 419 CHOUT = ' Warning: sentinel 0 0 0 missing on refl.file !' CALL SHOUT GOTO 417 420 ICARD = MOD (ICARD,3) + 1 IF (ICARD .EQ. 1) THEN READ (IHKL, 422) IE, * (HH(1,I), HH(2,I), HH(3,I), JJ(I), FF(I), SS(I), I=1,3) 422 FORMAT (A1, 3F3.0, I2, F7.2, F5.2, 2(1X,3F3.0, I2, F7.2,F5.2)) IF (IE .EQ. 'E') GOTO 417 ENDIF CALL KERNAB (HH(1,ICARD), HKL, 3) IF (ABS(HKL(1)) + ABS(HKL(2)) + ABS(HKL(3)) .LT. 0.1) GOTO 420 JC = JJ(ICARD) FOBS = FF(ICARD) SIG = SS(ICARD) RETURN 430 READ (IHKL, 435, END=419) HKL, FOBS, SIG 435 FORMAT (3F4.0, 2F8.2) IF (ABS(HKL(1)) + ABS(HKL(2)) + ABS(HKL(3)) .LT. 0.1) GOTO 417 IF (TRANS) THEN CALL KERNAB (HKL, HT, 3) DO 437 I = 1,3 HKL(I) = 0.0 DO 437 J = 1,3 437 HKL(I) = HKL(I) + HT(J) * HH(I,J) ENDIF JC = 0 438 IF (.NOT. F2) RETURN FOBS = AMAX1 (FOBS, SIG / 100. , 0.0001) FOBS = SQRT(FOBS) SIG = SIG / (2. * FOBS) RETURN 440 CALL KERINA( IHKL, LIT(32),1, KEND) IF (KEND .NE. 0 .OR. CHIN(1:6) .EQ. '_publ_') GOTO 417 CALL KERNAB (FNUM, HKL, 3) FOBS = FNUM(4) SIG = FNUM(5) GOTO 438 END SUBROUTINE LOGMER (NREF, HMAX, HMIN, HKLMAX, STLMAX, SCALE, BOV) DIMENSION HMAX(3), HMIN(3), HKLMAX(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 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)) CALL LOGRD (IDDL, 'MERBSC', KLOG) IF (KLOG .LT. 0 .OR. LIT(2) .NE. 'SCALE') GOTO 188 IF (NINT (10000.*SCALE) .NE. NINT(10000.*FNUM(2)) ) GOTO 188 IF (NINT (1000.*BOV) .NE. NINT(1000.*FNUM(3)) ) GOTO 188 CALL LOGRD (IDDL, 'NREF', KLOG) IF (KLOG .LT. 0 .OR. FNUM(2) .LT. 0.9) GOTO 188 IF (NREF .NE. NINT(FNUM(2)) ) GOTO 188 NREF = 0 RETURN 188 WRITE (CHOUT, 200) NREF, HMAX, HMIN 200 FORMAT ('NREF ', I6, ' HMAX ', 3F5.0, ' HMIN ', 3F5.0) CALL LOGWR (IDDL) WRITE (CHOUT, 220) STLMAX, HKLMAX 220 FORMAT ('STLMAX ', F7.5, ' HKLMAX ', 3F6.0) CALL LOGWR (IDDL) WRITE (CHOUT, 230) SCALE, BOV 230 FORMAT ('SCALE ', F14.7, ' BOV ', F10.5, ' MERBSC') CALL LOGWR (IDDL) RETURN END SUBROUTINE WILSIM 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 /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 /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) PARAMETER (MAXAT = 993) COMMON / / SICO(12500), FF(500,10), EXPBP(500), EXPBR(500), * SUMF2(500), SUMF2P(500), SFAC(13,10), * ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) COMMON / WILS / NOW(9), NUW(9), AW(9), AAW(9), BW(9), * NOV(7,7), NUV(7,7), VA(7,7), VB(7,7), VC(7,7), * VS(7,7) , FHMN, BPMAX, BPMIN, BRMAX, * BRMIN, BPINP, BRINP, KEYWIL, PSQM, * EPMAX, EPMIN PARAMETER (NRS = 9) LOGICAL SWIL DATA SWIL / .FALSE. / DATA STLM2, FNRS3 / 0.0 , 0.0 / IF (SWIL) GOTO 180 KEYWIL =-1 EPMIN = 9999. EPMAX =-9999. CALL KERNZI (0 , NOW, NRS) CALL KERNZI (0 , NUW, NRS) CALL KERNZA (0., AW, NRS) CALL KERNZA (0., AAW, NRS) CALL KERNZA (0., BW, NRS) FHMN = 0. SWIL = .TRUE. FNRS3 = FLOAT(NRS+1) STLM2 = STLMAX**2 BPINP = BP BRINP = BR BPMAX = 10. BPMIN = 0. BRMAX = 10. BRMIN = 0. 180 ISS = IFIX (STL * 400. + 1.5) FOBS = FOBS / EXPBR(ISS) CALL HKLEX1 (HKLX, HKLX) CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2) EPSIL = FLOAT(IEPS) TUMF2 = SUMF2(ISS) * EPSIL K = (STL2/STLM2) * (FNRS3) + 1. IF (K.GT.NRS) K = NRS IF (K.LT.1 .OR. K.GT.NRS) RETURN NOW(K) = NOW(K) + 1 IF (FOBS .LT. 5.*SIG) NUW(K) = NUW(K) + 1 FOBS = FOBS**2 / TUMF2 / ALATT AW(K) = AW(K) + FOBS BW(K) = BW(K) + STL2 RETURN END SUBROUTINE WRPEAK (KEY, BOV, HMAX) DIMENSION HMAX(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 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)) EQUIVALENCE (LIS2, IFILE(8)) EQUIVALENCE (IBINFO, IFILE(11)), (IBINS, 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 /CRYSB/ SPGR, WAVEAT, CELATY(10) CHARACTER SPGR *16, WAVEAT *2, CELATY *2 COMMON /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) DIMENSION FITFO(3) EQUIVALENCE (HCODE, FITFO(1)) DIMENSION HKL(3) EQUIVALENCE (HKL(1), HKLX(1,1)) PARAMETER (MAXAT = 993) COMMON / / SICO(12500), FF(500,10), EXPBP(500), EXPBR(500), * SUMF2(500), SUMF2P(500), SFAC(13,10), * ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) PARAMETER (MAXBUF = 198) PARAMETER (MAXA = 10000) COMMON /BUFREF/ BUFS(MAXBUF), BUFFO(MAXBUF), AREF(4, MAXA) DIMENSION FH(5,10), FHSUM(5,10), FHSYS(5,10), RHO(5,10) DIMENSION IKSYS(3), FBOV(5), ISYSAR(111) DIMENSION NWRP(100,2) LOGICAL CONT1 DATA CONT1 / .FALSE. / IF (KEY .GT. 0) GOTO 151 IF (CONT1) GOTO 133 CALL KERNZI (0, NWRP, 200) CONT1 = .TRUE. 133 CONTINUE IPH = IFIX (STL * 100. + 1.5) IF (IPH .GT. 100) IPH = 100 IF (FOBS .GT. 2. * SIG) THEN NWRP(IPH, 1) = NWRP(IPH, 1) + 1 ELSE NWRP(IPH, 2) = NWRP(IPH, 2) + 1 ENDIF RETURN 151 CONTINUE STLPH = STLMAX IF (KEY .LT. 500) GOTO 166 I1 = IFIX (STLMAX * 100. + 1.5) / 2 DO 158 I = I1, 100 IF (NWRP(I, 1) + NWRP(I, 2) .LT. 10) GOTO 158 IF (NWRP(I, 1) .LT. NWRP(I, 2)) THEN STLPH = FLOAT(I-1) / 100. GOTO 166 ENDIF 158 CONTINUE 166 CONTINUE CALL KERNZA (0., FH, 50) CALL KERNZA (0., FHSUM, 50) CALL KERNZA (0., RHO, 50) IREFL = 0 INREPS = 0 CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NIT, BUFFO, KENDFO) 201 CALL BINIFF (0, IBINFO, 'BINFO', FITFO, NIT, BUFFO, KENDFO) IF (KENDFO.LT.0) GOTO 220 IF (FOBS .LT. SIG) GOTO 201 CALL HKLC1U (HCODE, HKLX) CALL HKLSTL (HKLX, STL, STL2) ISS = IFIX (STL * 400. + 1.5) IF (STL .GT. STLPH) GOTO 201 IREFL = IREFL + 1 CALL HKLEX1 (HKLX, HKLX) CALL HKLEX2 (HKLX, IDHKL, IEPS, IEPS2) EPSIL = FLOAT(IEPS) DO 205 I = 1,5 FACBOV = I-3 FBOV(I) = BOV + FACBOV * 0.1 * BOV EXPBOV = EXP(- FBOV(I) * STL2) DO 205 J = 1,NTYPE FH(I,J) = FF(ISS,J) * EXPBOV FHSUM(I,J) = FHSUM(I,J) + (FH(I,J)/EPSIL) IF (EPSIL.GT.1.01) INREPS = INREPS + 1 205 CONTINUE INREPS = INREPS / 5 GOTO 201 220 CALL KERNZA (0.,FHSYS,50) CALL KERNZI (0,ISYSAR,111) IF (ISYST.EQ.1) GOTO 230 IF (ISYST.EQ.2) THEN CALL KERNZI (0,IKSYS,3) IKSYS(IUNIQ)=1 CALL SYSEX (IKSYS,HMAX,BOV,FHSYS,ISYSAR, STLPH) CALL KERNZI (1,IKSYS,3) IKSYS(IUNIQ)=0 CALL SYSEX (IKSYS,HMAX,BOV,FHSYS,ISYSAR, STLPH) ENDIF IF (ISYST.EQ.3) THEN DO 225 IC = 1,3 CALL KERNZI (1,IKSYS,3) IKSYS(IC) = 0 CALL SYSEX (IKSYS,HMAX,BOV,FHSYS,ISYSAR, STLPH) 225 CONTINUE ENDIF IF (ISYST.GE.4) THEN CALL KERNZI (1,IKSYS,3) CALL SYSEX (IKSYS,HMAX,BOV,FHSYS,ISYSAR, STLPH) ENDIF 230 FMULTT = FLOAT( 2 * NSYMM * NLATT ) DO 240 I = 1, 5 DO 240 J = 1, NTYPE RHO(I,J) = (FLOAT(IZTYPE(J)) + * ((FMULTT * FHSUM(I,J)) + (2. * FHSYS(I,J))) )/ VOLUM 240 CONTINUE WRITE (LIS2, FMT='('' Write expected atomic peak heights'', * '' (for various B values) to DDLOG'')') WRITE(CHOUT, 245) (FBOV(IT), IT=1,5) 245 FORMAT ('WRPEAK B',2X,5F7.3) CALL LOGWR (IDDL) WRITE (LIS2, FMT='('' Possible isotropic B values '', 35(''-'')/ * '' Expected peak height for ATOM'')') DO 260 J = 1,NTYPE WRITE(CHOUT, 250)J,CELATY(J), (RHO(I,J),I=1,5) 250 FORMAT ('TYPE',I3,1X,A2,1X,5F7.2) CALL LOGWR (IDDL) 260 CONTINUE WRITE(LIS2,FMT='('' TEMP h k l nr of syst.ext. refl'',/ * '' -------------- for hemisphere H > 0'')') DO 270 I=0,1 DO 270 J=0,1 DO 270 K=0,1 IKCODE = (100*I)+(10*J)+K IF (IKCODE.EQ.0) GOTO 270 IF (ISYSAR(IKCODE) .GT. 0) * WRITE (LIS2,265)I,J,K,ISYSAR(IKCODE) 265 FORMAT (' Refl:',3I3,I10) 270 CONTINUE WRITE(LIS2,FMT='('' TEMP: Nr refl. Epsil>1.0 :'', I6)')INREPS RETURN END SUBROUTINE SYSEX (IKSYS,HMAX,BOV,FHSYS,ISYSAR, STLPH) 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 EQUIVALENCE (IDDL, IFILE(1)) 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 /CRYSB/ SPGR, WAVEAT, CELATY(10) CHARACTER SPGR *16, WAVEAT *2, CELATY *2 COMMON /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) PARAMETER (MAXAT = 993) COMMON / / SICO(12500), FF(500,10), EXPBP(500), EXPBR(500), * SUMF2(500), SUMF2P(500), SFAC(13,10), * ATXYZ(10,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) DIMENSION HMAX(3), HKL(3), FH(5,10), FHSYS(5,10) DIMENSION IHMAXT(3), IKSYS(3), ISYSAR(111) CALL KERNZA (0., FH, 50) DO 200 I=1,3 IF (IKSYS(I).EQ.0) THEN IHMAXT(I) = 0 ELSE IHMAXT(I) = NINT(HMAX(I)) - 1 ENDIF 200 CONTINUE STLMT = AMIN1 (0.90 * STLMAX, STLPH) DO 229 IH=0,IHMAXT(1) IF ((ISYST.EQ.3).AND.(IH.EQ.0)) THEN IF ((IKSYS(2).EQ.0).OR.(IKSYS(3).EQ.0)) GOTO 229 ENDIF HKL(1)=IH DO 228 IK=-IHMAXT(2),IHMAXT(2) IF ((ISYST.EQ.3).AND.(IKSYS(3).EQ.0).AND.(IK.EQ.0)) GOTO 228 HKL(2)=IK DO 227 IL=-IHMAXT(3),IHMAXT(3) HKL(3)=IL CALL HKLSTL (HKL, STL, STL2) IF (STL.GT.STLMT) GOTO 227 ISS = IFIX (STL * 400. + 1.5) CALL HKLC1(HKL,HCODE) CALL HKLAXT (HKL, KEND) IF (KEND.LT.0) GOTO 227 CALL HKLEXT (HKL, KEND) IF (KEND.LT.0) THEN IKCODE = 0 IF (NINT(HKL(1)).NE.0) IKCODE = IKCODE + 100 IF (NINT(HKL(2)).NE.0) IKCODE = IKCODE + 10 IF (NINT(HKL(3)).NE.0) IKCODE = IKCODE + 1 ISYSAR(IKCODE) = ISYSAR(IKCODE) + 1 DO 223 I = 1,5 FACBOV = I-3 BOVMOD = BOV + FACBOV * 0.1 * BOV EXPBOV = EXP(- BOVMOD * STL2) DO 223 J = 1,NTYPE FH(I,J) = FF(ISS,J) * EXPBOV FHSYS(I,J) = FHSYS(I,J) + FH(I,J) 223 CONTINUE ENDIF 227 CONTINUE 228 CONTINUE 229 CONTINUE RETURN END SUBROUTINE WILPAR (IWILP) 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 LOGICAL SWIPRI EQUIVALENCE (SWIPRI, SWITCH(10)) EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) COMMON /FCALCA/ BP, BR, SCALE, HKLMAX(3), STLMAX, * IZTYPE(10), CELPAR(10), PSQ, P1SQ, ITRS(24), * AMULT, ASYMM, ALATT, ASYMCL, NSYMC, ASYMC, * HKLX(3,24), IDHKL(24), HCODE, FOBS, SIG, * STL, STL2, ISS, ENORM, * FP, PHIP, FAP, FBP, EPSIL, * EPSIL2, SF2, SF2P, FPEXP(2,24) COMMON / WILS / NOW(9), NUW(9), AW(9), AAW(9), BW(9), * NOV(7,7), NUV(7,7), VA(7,7), VB(7,7), VC(7,7), * VS(7,7) , FHMN, BPMAX, BPMIN, BRMAX, * BRMIN, BPINP, BRINP, KEYWIL, PSQM, * EPMAX, EPMIN PARAMETER (BDMAX = 1.0) IWILP = 1 IF (KEYWIL.EQ.4) RETURN IF (.NOT. SWIPRI) GOTO 220 IF (KEYWIL.GE.0) THEN WRITE (LIS2, 200) 200 FORMAT(/ ' Data for WILSON-PARTHASARATHY plot:', /, * ' Range NOBS NUNOBS <(FP2+F2R)/F2> STL2 ', * ' ln') ELSE WRITE (LIS2, 210) 210 FORMAT(/ ' Data for WILSON plot:', /, * ' Range NOBS NUNOBS STL2 ln') ENDIF 220 NRS = 9 NNOW = 0 DO 230 I=1,NRS 230 NNOW = NNOW + NOW(I) IF (NNOW.GT. 399) GOTO 250 J = 0 DO 240 I=1,(NRS-1),2 J = J + 1 NOW(J) = NOW(I) + NOW(I+1) NUW(J) = NUW(I) + NUW(I+1) AW(J) = AW(I) + AW(I+1) AAW(J) = AAW(I) + AAW(I+1) 240 BW(J) = BW(I) + BW(I+1) NOW(J) = NOW(J) + NOW(NRS) NUW(J) = NUW(J) + NUW(NRS) AW(J) = AW(J) + AW(NRS) AAW(J) = AAW(J) + AAW(NRS) BW(J) = BW(J) + BW(NRS) NRS = J 250 I = 1 260 IF (NNOW.GT.399 .AND. NOW(I).GT.25) GOTO 280 IF (NNOW.LE.399 .AND. NOW(I).GT.NNOW/20) GOTO 280 NRS = NRS - 1 IF (I.GT.NRS) GOTO 320 DO 270 J=I,NRS NOW(J) = NOW(J+1) NUW(J) = NUW(J+1) AW(J) = AW(J+1) AAW(J) = AAW(J+1) 270 BW(J) = BW(J+1) GOTO 260 280 AW(I) = AW(I) / NOW(I) AAW(I) = AAW(I) / NOW(I) BW(I) = BW(I) / NOW(I) IF (AAW(I).LT.0.001 .OR. KEYWIL.EQ.-1) AAW(I) = 1.0 X1 = ALOG(AW(I) / AAW(I)) IF (.NOT. SWIPRI) GOTO 310 IF (KEYWIL.GE.0) THEN WRITE (LIS2, 290) I, NOW(I), NUW(I), AW(I), AAW(I), BW(I), X1 290 FORMAT (1X, I3, I8, I5, F11.4, F13.4, F11.4, F13.4) ELSE WRITE (LIS2, 300) I, NOW(I), NUW(I), AW(I), BW(I), X1 300 FORMAT (1X, I3, I8, I5, F11.4, F8.4, F10.4) ENDIF 310 AW(I) = X1 I = I + 1 IF (I.LE.NRS) GOTO 260 320 IF (NRS.LE.1) THEN WRITE (LIS1, 330) NRS WRITE (LIS2, 330) NRS 330 FORMAT (' WILSON-PARTHASARATHY plot not possible, number of', * ' ranges: ', I3) RETURN ENDIF IF (KEYWIL .NE. -1) THEN WRITE (LIS2, FMT='('' Input values for WILSON-PARTHASARATHY'', * '' plot: Bp ='', F7.3, '' Br ='', F7.3)') BP, BR WRITE (LIS2, 340) 340 FORMAT (' WILSON-PARTHASARATHY plot '/ * ' LN ') WRITE (LIS1, FMT='(A)') ' WILSON-PARTHASARATHY plot ' ELSE WRITE (LIS2, FMT='('' Input values for WILSON plot: '', * '' Overall B ='', F7.3,'' Scale SC ='', F9.5)') BP, SCALE WRITE (LIS2, 350) 350 FORMAT (' WILSON plot' / ' LN ') WRITE (LIS1, FMT='(A)') ' WILSON plot results' ENDIF CALL WILDUP (AW, BW, NOW, NUW, NRS, C, S, R) IWILP = 0 IF (SWITCH(1)) WRITE (LIS2, 3511) SCALE, BPINP, BRINP, BP, BR 3511 FORMAT (' PTB: TEMP: SCALE BpINP BrINP BP BR:', 2(3F9.5, 3X) ) SCALE = EXP(-0.5 * C) BD = -0.5 * S BP = BP + BD BR = BR + BD IF (SWITCH(1)) WRITE (LIS2, 3512) SCALE, BP, BR 3512 FORMAT (' PTB: TEMP: WILSON SCALE Bp Br: new:', 2(3F9.5, 3X) ) WRITE (LIS2, 356) 356 FORMAT ( ' Results are applied (as shifts)', * ' to the input values. New values are:') IF (ABS(BP-BR).LT.0.001) THEN WRITE (LIS1, 360) SCALE, BP WRITE (LIS2, 360) SCALE, BP 360 FORMAT (' Scale and overall temperature factor: Scale =', * F9.5, ' Bov:', F6.3) ELSE WRITE (LIS1, 370) SCALE, BP, BR WRITE (LIS2, 370) SCALE, BP, BR 370 FORMAT (' Scale and B-values to be used: Scale =', * F9.5, ' Bp =', F6.3, ' Br =', F6.3) ENDIF IF (KEYWIL.LE.0) GOTO 390 IF (KEYWIL.EQ.1 .OR. KEYWIL.EQ.3) BP = BP - BD IF (KEYWIL.EQ.2 .OR. KEYWIL.EQ.3) BR = BR - BD WRITE (LIS2, 380) KEYWIL, SCALE, BP, BR WRITE (LIS1, 380) KEYWIL, SCALE, BP, BR 380 FORMAT (' (KEYWIL = ', I2, ') Reset: Scale =', F9.5, * ' Bp =', F6.3, ' Br =') 390 CONTINUE IF (KEYWIL.EQ.-1) BD = 0.0 IF (BP.GT.0.001 .AND. BR.GT.0.001 .AND. ABS(BD).LT.1. .AND. * SCALE.GT.0.001) RETURN SIGNBD = SIGN(BDMAX,BD) IF (KEYWIL.LE.0) BP = BPINP + SIGNBD IF (KEYWIL.LE.1) BR = BRINP + SIGNBD IF (KEYWIL.EQ.2) BP = BPINP + SIGNBD SCALE = 0.0 KRSTL = 8 * NRS / 10 IF (NRS.LE.5) KRSTL = 4 IF (NRS.LT.4) KRSTL = NRS DO 400 I=1,KRSTL 400 SCALE = SCALE - AW(I) - 2.0*BW(I)*(BP-BPINP) SCALE = EXP (0.5 * SCALE / KRSTL) WRITE (LIS1, 410) WRITE (LIS2, 410) 410 FORMAT (' Resetting of temperature factors and scale required:') WRITE (LIS1, 370) SCALE, BP, BR WRITE (LIS2, 370) SCALE, BP, BR RETURN END SUBROUTINE WILDUP (Y, X, NOW, NUW, N, C, S, R) 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)) DIMENSION X(N), Y(N) DIMENSION NOW(N), NUW(N) DIMENSION YAXIS(6), XAXIS(6) CHARACTER * 1 BLANK, STAR, CH(78) DATA BLANK, STAR / ' ', '*' / KTEST = 0 SY = 0.0 SYY = 0.0 SX = 0.0 SXX = 0.0 SXY = 0.0 YMIN = Y(1) YMAX = YMIN XMAX = X(N) * 1.125 W = FLOAT(N) WWW = 0. DO 150 I=1,N WW = MAX0 (1, NOW(I) - NUW(I) ) WWW = WWW + WW IF (Y(I).LT.YMIN) YMIN = Y(I) IF (YMAX.LT.Y(I)) YMAX = Y(I) SY = SY + WW * Y(I) SYY = SYY + WW * Y(I)**2 SX = SX + WW * X(I) SXX = SXX + WW * X(I)**2 150 SXY = SXY + WW * X(I)*Y(I) S = (SY*SX - WWW*SXY) / (SX*SX - WWW*SXX) C = (SY - S*SX) / WWW YSCAL = 0.2 * (YMAX-YMIN) YMAX = YMAX + YSCAL YMIN = YMIN - YSCAL YSCAL = YMAX - YMIN YFAC = 20./YSCAL XFAC = 80./XMAX YAXIS(1) = YMAX XAXIS(1) = 0.00001 DO 210 I=2,6 FI1 = FLOAT(I-1) XAXIS(I) = XMAX/5.0*FI1 210 YAXIS(I) = YMAX - (YSCAL/5.*FI1) CALL KERNZ1 (STAR, CH, 78) WRITE (LIS2, 220) STAR, YAXIS(1), (CH(II),II=7,78) 220 FORMAT (' ', A1, F5.2, ' ', 72A1) M = 2 DO 260 I=2,19 FI20 = FLOAT(20 - I) CALL KERNZ1 (BLANK, CH, 78) CH(1) = '*' L = ((YMIN + (YSCAL* FI20) /20.) -C)/S*XFAC + 0.5 L1 = ((YMIN + (YSCAL* (FI20-1.)) /20.) -C)/S*XFAC + 0.5 IF (L.GT.0 .AND. L.LE.78) CH(L) = '.' IF (ABS(L1-L).LE.5) GOTO 229 IF (S.LT.0.00001) THEN I1 = L + 3 I2 = L1 - 3 ELSE I1 = L1 + 3 I2 = L - 3 ENDIF IF (I1.LE. 1) I1 = 2 IF (I2.GT.78) I2 = 78 DO 225 I12=I1,I2,3 225 CH(I12) = '.' 229 DO 230 J=1,N K = (Y(J)-YMIN)*YFAC + 0.5 + FLOAT(I) L = X(J)*XFAC + 0.5 IF (K.EQ.20 .AND. L.LE.78) CH(L) = 'X' IF (K.EQ.20 .AND. L.GT.78) CH(78)= '+' 230 CONTINUE IF (I/4*4.EQ.I) GOTO 250 WRITE (LIS2, 240) CH 240 FORMAT (1H , 78A1) GOTO 260 250 WRITE (LIS2, 220) STAR, YAXIS(M), (CH(II), II=7,78) M = M + 1 260 CONTINUE CALL KERNZ1 (STAR, CH, 78) WRITE (LIS2, 220) STAR, YAXIS(6), (CH(II), II=7,78) WRITE (LIS2, 270) (XAXIS(II), II=2,6) 270 FORMAT (F15.3, 4F16.3) WRITE (LIS2, 280) 280 FORMAT (60X, '(sinTHETA/LAMBDA)**2') IF (SWIPRI) WRITE (LIS2, 290) N, S, C 290 FORMAT (/' Line based on', I10, ' points, slope is ', F10.4, / * ' intercept is ', F10.4) RETURN END