PROGRAM NUTS ********************************************* NUTS FORTRAN = NUTS FOR ***** Nijmegen UTilety System ************** Last update: 11 Nov. 1999 ***** with subprograms : ************** >>>>>>> see CSUBPROG for: ***** AT2X, X2AT, SHAT, INVERT, PRIFC, BINPRI, BIJVOET, EULER ..... etc. ***** NUTS LOG of recent modifications (last on top: C 11 Nov DDOKA STOP 99 C 22 Feb. 1999 Outout SCHAKAL file (SCAHAKL): 'ATOM ' x y z (Struempl) 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 (IDDJ, IDDS, IFILE(1)) EQUIVALENCE (ICRYS, IFILE(3)), (ICON, IFILE(4)), (IPR1, IFILE(6)) EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IBINFO, IFILE(13)) EQUIVALENCE (IRUN, KEYS(13)) LOGICAL SWHAND, NIJMEG EQUIVALENCE (SWHAND, SWITCH(28)) EQUIVALENCE (NIJMEG, SWITCH(1)) CHARACTER * 2 ISTAR CHARACTER *6 L(20), LL CHARACTER *72 FMHELP(8) DATA LMAX, LMAXP / 20, 15/ DATA L / 'NUTS' , 'AT2X' , 'X2AT' , 'FR2BIN', 'BIN2FR', * 'BIJVOE', 'SHAT' , 'EULER' , 'INVERT', 'BINPRI', * 'METFOU', 'SHELIN', 'SELECT', 'PRIFC' , 'SHELXL', * '????' , 'MISFIT', 'R' , 'H' , 'Q' / DATA ISTAR / '**' / DATA FMHELP / *' AT2X, X2AT : transform ATOMS file to SHELX XYZN file, and v.v.', *' FR2BIN, BIN2FR: transform FREF file to BINary file, and v.v.' , *' BINPRI : print BINary data files (BINFO BINFC(2) BINFFT)' , *' SHAT, EULER and INVERT : shift, rotate or invert atomic coords', *' METFOUR : (obsolete)', *' PRIFC : print FC: combines a BINFO and a BINFC file )', *' SELECT : select an atom set from file CCODE ATOLD (ERROR!)', *' BIJVOET : calculate Bijvoet coefficients (:absolute conf.!)' / DATA ICONT /0/ CALL KEPROG ('NUTS') WRITE (LIS2, FMT = '('' Last NUTS update: 11 Nov. 1999'')') CHOUT = '0Nijmegen UTility System' CALL SHOUT2 IF (IRUN .GT. 1) THEN WRITE (CHOUT, FMT = '(66X, ''RUN'', I3)') IRUN CALL SHOUT ENDIF CALL FILINQ (IDDJ, 'DDJOB', 'FORMATTED', 'INPUT', KEND) CALL FILCLO (IDDJ, 'KEEP') IF (KEND .NE. 0) GOTO 107 LL = LIT(2) IF (LL .EQ. 'NUTS') LL = LIT(3) IF (LL .EQ. ' ') GOTO 107 IF (LL .NE. 'MISFIT') GOTO 106 WRITE (IPR1, 103) WRITE (LIS1, 103) WRITE (LIS2, 103) 103 FORMAT (/' Present procedure for MISFIT structures:' / * ' structure solution for one of the layers completed, '/ * ' control passed on to program MISFIT' /) CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ) WRITE (IDDS, FMT='(''MISFIT'')') WRITE (IDDS, FMT='(''STOP'')') REWIND IDDS CALL FILCLO (IDDS, 'KEEP') CALL KEPROX GOTO 999 106 CALL KEREQ6 (LL, L, LMAXP, KEND) IF (KEND .LE. 0 .OR. KEND .GT. LMAXP) GOTO 107 GOTO 206 107 CALL RDCOND (ICON, L, 1, KEND) LL = LIT(2) IF (LL .EQ. 'NUTS') LL = LIT(3) IF (KEND .EQ. 1) CALL RDCOND (ICON, L, 1, KKKK) CALL FILCLO (ICON, 'KEEP') IF (KEND .NE. 1) GOTO 110 IF (LL .EQ. ' ') GOTO 110 CALL KEREQ6 (LL, L, LMAXP, KEND) IF (KEND .LE. 0 .OR. KEND .GT. LMAXP) GOTO 110 GOTO 206 110 ICONT = 1 WRITE (IPR1, 112) (L(J), J=2,LMAXP) 112 FORMAT (' Select one of the following options (or R or H or Q):' * / 10 (1X, A6) ) CALL KETERM (0, 1, KEND) IF (KEND .LT. 0) GOTO 110 LL = LIT(1) IF (LL .EQ. 'Q') GOTO 990 IF (LL .EQ. 'R') GOTO 110 IF (LL .EQ. 'H') THEN DO 114 I = 1, 8 114 WRITE (IPR1, FMT = '(A72)') FMHELP(I) GOTO 110 ENDIF SWHAND = .TRUE. CALL KEREQ6 (LL, L, LMAX, KEND) IF (KEND.LE.1) THEN WRITE (IPR1, 202) 202 FORMAT (' Answer not understood: please, try again:') GOTO 110 ENDIF 206 PROGNM = LL IF (PROGNM .EQ. 'METFOU') PROGNM = 'METFOUR' IF (PROGNM .EQ. 'BIJVOE') PROGNM = 'BIJVOET' WRITE (LIS2, 207) (ISTAR, I=1,23), PROGNM, (ISTAR, I=1,23) 207 FORMAT (/ 1X, 23A2 / ' ****', 38X, '****' / ' ****', 16X, A8, + 14X, '****' / ' ****', 38X, '****' / 1X, 23A2 ) WRITE (CHOUT, FMT='(''0============ Program '', A8)') PROGNM IF (CCODE .NE. 'NONAME') THEN LIT(31) = ' ' IF (CCODE(5:6) .EQ. ' ') THEN LIT(31)(3:6) = CCODE(1:4) ELSEIF (CCODE(6:6) .EQ. ' ') THEN LIT(31)(2:6) = CCODE(1:5) ELSE LIT(31) = CCODE ENDIF WRITE (CHOUT, FMT='(''0============ Execute program '', A8, * '' ============ for compound: '', A6 )') PROGNM, LIT(31) LIT(31) = ' ' ENDIF CALL SHOUT GOTO (2,2,3,4,5,6,7,8,9,10,11,12,13,14,15,18,18,18,19,20), KEND 2 CALL AT2X GOTO 770 3 CALL X2AT GOTO 770 4 CALL FR2BIN GOTO 770 5 CALL BIN2FR GOTO 770 6 CALL BIJVOE GOTO 770 7 CALL SHAT GOTO 770 8 CALL EULER GOTO 770 9 CALL INVERT IF (SWHAND) CALL SHAT GOTO 770 10 CALL BINPRI GOTO 770 11 CALL METFOU GOTO 770 12 CONTINUE WRITE (IPR1, 212) 212 FORMAT ( *' Various output files with atomic parameters ([-profile-]).'/ *' Note: XYZN = control data + atomic params for SHELXL 1993 !!'/ *' For use in SHELXL: rename CCODE.XYZN to CCODE.INS .') CALL AT2X GOTO 770 13 CALL SELECT GOTO 770 14 CALL PRIFC GOTO 770 15 CONTINUE IF (NIJMEG) WRITE (IPR1, 212) CALL AT2X GOTO 770 18 IF (ICONT.EQ.0) GOTO 800 GOTO 110 19 IF (ICONT.EQ.0) GOTO 800 WRITE (IPR1, 719) 719 FORMAT (' Possible options are:'/ * ' AT2X = convert ATOMS file to eXternal par. file format' / * ' X2AT = convert SHELX param. file to ATOMS file' / * ' FR2BIN = convert FREF file (refl.data) to binary file' / * ' BIJVOET calculate Bijvoet coefficient'/ * ' etc. , please try again:') GOTO 110 20 IF (ICONT.EQ.0) GOTO 800 WRITE (IPR1, 720) 720 FORMAT (' So you quit.') GOTO 990 770 IF (ICONT .EQ. 0) GOTO 990 WRITE (IPR1, 777) 777 FORMAT (' DONE'//' Do you wish to run more options? Say Q or:') GOTO 110 800 CALL KERROR ('Illegal parameter', 800, 'NUTS') 990 WRITE (CHOUT, 992) PROGNM 992 FORMAT ('0End of program ', A8) CALL FILINQ (ICON, 'CONDA', 'FORMATTED', 'TEST', KINQ) IF (KINQ .EQ. 0) THEN WRITE (LIS1, FMT='('' Existing CONDA file erased'')') CALL FILCLO (ICON, 'DELETE') ENDIF CALL FILINQ (IBINFO, 'BINFO', 'UNFORMATTED', 'TEST', KINQ) IF (KINQ .EQ. 0) GOTO 995 CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'TEST', KINQ) IF (KINQ .NE. 0) GOTO 995 CALL KERINA (ICRYS, LIT(32), 1, LEND) IF (NFNUM.LE.0 .OR. NLIT.LE.0) GOTO 994 IRUNCR = FNUM(NFNUM) IF (LIT(NLIT).EQ.'RUN' .AND. IRUNCR.EQ.KEYS(13)) THEN CALL FILCLO (ICRYS, 'DELETE') GOTO 995 ENDIF 994 WRITE (LIS1, FMT='(/'' Note: old CRYSDA file retained !!''/)' ) CALL FILCLO (ICRYS, 'KEEP') 995 PROGNM = 'NUTS' CALL KEPROX 999 CONTINUE WRITE (LIS2, FMT='(/'' Test: DDOKA exit MAIN SUBPROGRAM ''/)') STOP 99 END SUBROUTINE AT2X 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)), (ICRIN, IFILE(4)) EQUIVALENCE (IATOMS, IFILE(2)), (ICRYS, IFILE(3)) EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (ISPEK, IFILE(9)), (ISHEL, IFILE(11)) EQUIVALENCE (ISCHAK, IFILE(12)) EQUIVALENCE (IBINFO, IFILE(13)) EQUIVALENCE (IATX, KEYS(11)) 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 DIMENSION IUNIT(10),LATT(7) PARAMETER (NSLOT = 10, MAXAT = 2513) COMMON / / DUMMY(1), * ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), DUMMY(1)) COMMON /ATNAMA/ ATNAME(MAXAT) CHARACTER * 6 ATNAME PARAMETER (MAXBUF = 198) DIMENSION BUFFO(MAXBUF), FITFO(3) CHARACTER * 1 LR DIMENSION IZTYPA(10) PARAMETER (U2B = 8. * 3.141593 **2) DATA LATT / 1,5,6,7,2,4,3 / DATA TF / 0.06/ CALL FILINQ (IBINFO, 'BINFO', 'UNFORMATTED', 'TEST', KINQ) IF (KINQ .NE. 0) GOTO 109 CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO) IRUNFO = NINT (BUFFO(5)) IF (IRUNFO .EQ. - KEYS(13)) THEN CALL FILCLO (IBINFO, 'DELETE') GOTO 109 ENDIF WRITE (LIS1, FMT='(/'' Note: old BINFO file retained !!'')' ) 109 CALL RDCRYS (ICRYS) DO 110 I= 1, NTYPE 110 CALL ATOMIZ (CELATY(I), NLET, IZTYPA(I)) IF (IATX .EQ. 4 .OR. IATX .EQ. 5) THEN CALL FILINQ (ISCHAK, 'SCHAKL', 'FORMATTED', 'OUTPUT', KINQ) WRITE (ISCHAK, 217) CCODE WRITE (ISCHAK, 219) CELL WRITE (LIS1, FMT='( * '' Output SCHAKAL file is denoted SCHAKL or ccode.sch'')') ENDIF WRITE (LIS1, FMT='( * '' Output SHELX-INS file is denoted XYZN or ccode.xyzn'')') CALL FILINQ (ISHEL, 'XYZN' , 'FORMATTED', 'OUTPUT', KINQ) WRITE (ISHEL, FMT = '(''TITL XYZN file = SHELXL INS file,'', * '' from DIRDIF output for '', A6)') CCODE WRITE (ISHEL,115) WAVE, CELL 115 FORMAT ('CELL ',F8.5,2X,3F9.5,3F9.4) WRITE (ISHEL,125) ZET, CELLSD 125 FORMAT ('ZERR ',F9.3,2X,3F9.5,3F9.4) LR = '+' IF (ICENT .EQ. 1) LR = '-' WRITE (ISHEL, FMT = '(''LATT '', A1, I1)') LR, LATT(ILATT) IF (NSYMM .EQ. 1) GOTO 140 CALL RDCRYB (ICRYS, 'SYMIT', KEND) DO 135 I = 2,NSYMM READ (ICRYS, FMT = '(A80)') CHIN 135 WRITE (ISHEL, FMT = '(''SYMM '', A60)') CHIN(11:70) 140 WRITE (ISHEL, 145) (CELATY(I), I=1,NTYPE) 145 FORMAT('SFAC ',10(A2,3X)) DO 190 I = 1,NTYPE 190 IUNIT(I) = IFIX (CELALL(I) + 0.5) WRITE (ISHEL, FMT = '(''UNIT '', 10I5)') (IUNIT(I),I=1,NTYPE) WRITE (ISHEL, FMT = '(''L.S. 3'')') CHOUT = 'REM use BOND for distances and angles:' WRITE (ISHEL, FMT = '(A72)') CHOUT WRITE (ISHEL, FMT = '(''BOND'')') CHOUT='REM FMAP 3 = electr.dens., FMAP 2: Fo-Fc Fourier' WRITE (ISHEL, FMT = '(A72)') CHOUT WRITE (ISHEL, FMT = '(''FMAP 3'')') CHOUT = 'REM Plan n: print n additional Fourier peaks' WRITE (ISHEL, FMT = '(A72)') CHOUT CHOUT = 'REM Plan -n: print includes connectivity' WRITE (ISHEL, FMT = '(A72)') CHOUT WRITE (ISHEL, FMT = '(''PLAN -10'')') CHOUT='REM TEMP nn = Temperature of data collect. in Celcius' WRITE (ISHEL, FMT = '(A72)') CHOUT WRITE (ISHEL, FMT = '(''REM TEMP 20'')') CHOUT = 'REM SIZE = crystal size in mm :' WRITE (ISHEL, FMT = '(A72)') CHOUT WRITE (ISHEL, FMT = '(''REM SIZE 0.5 0.5 0.5 '')') WRITE (ISHEL, FMT = '(''REM crystal color and shape ?'')') CHOUT = 'REM Write atoms file in PDB format (with H) :' WRITE (ISHEL, FMT = '(A72)') CHOUT WRITE (ISHEL, FMT = '(''WPDB -1 '')') WRITE (ISHEL, FMT= '(''REM Warning: check HKLF below !! '')') WRITE (ISHEL, FMT= '(''REM ---------------------------- '')') WRITE (ISHEL, FMT= '(''REM 3=Fobs, 4=FobsSQ, > HKL file '')') CHOUT = ' ' IF (IATX .NE. 3 .AND. IATX .NE. 5) GOTO 225 WRITE (LIS1, FMT='( * '' Output for PLUTON (Spek) is CCODE.SPF or ccode.spf''/)') CALL FILINQ (ISPEK, 'SPF', 'FORMATTED', 'OUTPUT', KINQ) WRITE (ISPEK, 217) CCODE 217 FORMAT ('TITL : DIRDIF output for : ',A6) WRITE (ISPEK, 219) CELL 219 FORMAT ('CELL ',6F10.5) WRITE (ISPEK, 221) SPGR 221 FORMAT ('SPGR ',A16) 225 CONTINUE CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ) IF (KINQ.EQ.-1) CALL KERROR (' No ATOMS file found', * 225, 'AT2X') FVAR = - 999. CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT) CHOUT = ' Transform ATOMS parameter file format to: ' CALL SHOUT IF (IATX .EQ. 0) THEN CHOUT = ' XYZN (INS) file ' ELSEIF (IATX .EQ. 3) THEN CHOUT = ' SPF and XYZN (INS) files' ELSEIF (IATX .EQ. 4) THEN CHOUT = ' SCHAKAL and XYZN (INS) files' ELSEIF (IATX .EQ. 5) THEN CHOUT = ' SPF, SCHAKAL and XYZN (INS) files' ELSE CHOUT = ' XYZN (INS) file ' ENDIF CALL SHOUT IF (NFNUM .LE. 0) GOTO 231 IF (LIT(NLIT). EQ. 'SC=' .AND. FNUM(NFNUM) .GT. 0.001) THEN FVAR = 1. / FNUM(NFNUM) CHOUT = ' FVAR = 1 / SCALE from the ATOMS file ' CALL SHOUT ENDIF 231 CALL LOGRD (IDDL, 'MERBSC', KLOG) IF (KLOG .GT. 0 .AND. LIT(2) .EQ. 'SCALE') THEN IF (FVAR .LT. 0.0) THEN FVAR = 1. / FNUM(2) CHOUT=' FVAR = 1 / MERBIN scale (from the DDLOG file)' CALL SHOUT ENDIF TF = FNUM(3) /U2B CHOUT = ' MERBIN U(iso) (from the DDLOG file)' CALL SHOUT ENDIF IF (FVAR .LT. 0.0) FVAR = 1. WRITE(ISHEL, FMT = '(''FVAR '', F10.5)') FVAR CALL ATOMST (1, ATXYZ, NAT, KEYT) DO 300 I = 1,NAT ISF = 0 DO 235 J=1,NTYPE IF (IZAT(I) .EQ. IZTYPA(J)) THEN ISF = J GOTO 250 ENDIF 235 CONTINUE WRITE (CHOUT, 240) ATNAME(I) 240 FORMAT (' Atom ', A6,' not found in CRYSDA file', *' ISFAC=0 was assigned' ) IF (ATNAME(I)(1:1).EQ.'Q') CHOUT(14:38) = ' is a peak (disorder?)' CALL SHOUT 250 IF (ATXYZ(5,I) .LE. 0.0001) ATXYZ(5,I) = TF ATXYZ(4,I) = 11.0 KK = 10 IF (ATXYZ(6,I) .LE. 0.00001) KK = 5 WRITE (ISHEL, 260) ATNAME(I)(1:4), ISF, (ATXYZ(K,I) ,K=1,KK) 260 FORMAT (A4, I5, 6F10.5, ' =' / 9X, 4F10.5 ) IF (IATX .EQ. 3 .OR. IATX .EQ. 5) * WRITE (ISPEK, 276) ATNAME(I), (ATXYZ(J,I),J=1,3) 276 FORMAT (A6,2X,3F10.5) IF (IATX .EQ. 4 .OR. IATX .EQ. 5) * WRITE (ISCHAK, 277) ATNAME(I), (ATXYZ(K,I),K=1,3) 277 FORMAT ('ATOM ',A6,2X,3F10.5) 300 CONTINUE CALL FILCLO (ICRIN, 'KEEP') CALL FILINQ (ICRIN, 'CRYSIN', 'FORMATTED', 'INPUT', KCRIN) IHKLF = 0 IF (KINQ.EQ.-1) GOTO 304 301 CALL KERINA (ICRIN, LIT(32), 1, LEND) IF (LEND .NE. 0) GOTO 304 IF (CHIN(1:4) .NE. 'HKLF') GOTO 301 IF (NFNUM .LE. 0) GOTO 304 IHKLF = IABS (NINT (FNUM(1))) IF (IHKLF .NE. 3 .AND. IHKLF .NE. 4) GOTO 304 304 CALL FILCLO (ICRIN, 'KEEP') IF (IHKLF .EQ. 0) THEN WRITE (ISHEL, FMT = '(''REM HKLF ?? '')') ELSE WRITE (ISHEL, FMT = '(''HKLF '',I3)') IHKLF ENDIF WRITE (ISHEL, FMT = '(''END '')') CALL FILCLO (ISHEL, 'KEEP') IF (IATX .EQ. 3 .OR. IATX .EQ. 5) THEN WRITE (ISPEK, 311) 311 FORMAT ('LABELS OFF'/'BOX OFF'/'EXCL Q'/'STRAW COL'/'PLOT') CALL FILCLO (ISPEK, 'KEEP') ENDIF IF (IATX .EQ. 4 .OR. IATX .EQ. 5) CALL FILCLO (ISCHAK, 'KEEP') IRUN = -999 KPROG = 999 CALL LOGRD(IDDL, 'NAT=', KLOG) IF (KLOG .GT. 0) IRUN = NINT(FNUM(2)) IF (IRUN .EQ. KEYS(13)) KPROG= NINT(FNUM(4)) IF (KPROG .GE. 1 .AND. KPROG .LE. 10) GOTO 345 WRITE (LIS1, FMT='(/'' First 7 records of ATOMS file:'')') REWIND IATOMS DO 327 I = 1, 7 CALL KERINA (IATOMS, LIT, 1, LENDX) 327 WRITE (LIS1, FMT='(1X,A80)') CHIN WRITE (LIS1, FMT='(/)') 345 REWIND ICRYS CALL KERINA (ICRYS, LIT, 1, LENDX) IF (LIT(NLIT) .EQ. 'KEEP') GOTO 900 IF (IRUN .NE. KEYS(13)) GOTO 900 IF (KPROG .GT. 10 .OR. KPROG .LE. 0) GOTO 999 CALL FILCLO (ICRYS, 'DELETE') GOTO 999 900 WRITE (LIS1,FMT='('' Existing (old) CRYSDA file retained'')') 999 CONTINUE CALL FILCLO (IDDL, 'KEEP') CALL FILCLO (IATOMS, 'KEEP') CALL FILCLO (ICRYS, 'KEEP') WRITE (IPR1, 212) 212 FORMAT ( *' Note: XYZN = control data + atomic parameters for SHELXL !!'/ *' For use in SHELXL: rename file CCODE.XYZN to CCODE.INS .') CALL WRLIS2 RETURN END SUBROUTINE X2AT 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 (IXYZN, IFILE(1) ) EQUIVALENCE (IATOMS, IFILE(2) ) EQUIVALENCE (ICRYS, IFILE(3) ) EQUIVALENCE (IRD, IFILE(5) ) EQUIVALENCE (IPR1, IFILE(6) ) EQUIVALENCE (IATOLD, IFILE(10)) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) COMMON /CRYSB/ SPGR, WAVEAT, CELATY(10) CHARACTER SPGR *16, WAVEAT *2, CELATY *2 PARAMETER (NSLOT = 10, MAXAT = 2513) COMMON / / DUMMY(1), * ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), DUMMY(1)) COMMON /ATNAMA/ ATNAME(MAXAT) CHARACTER * 6 ATNAME DIMENSION B(MAXAT), NLET(10), IZTYPA(10) DIMENSION HU(MAXAT) CHARACTER * 1 ISF CALL RDCRYS (ICRYS) CALL FILINQ (IXYZN, 'XYZN', 'FORMATTED', 'INPUT', KINQ) IF (KINQ.EQ.-1) CALL KERROR ('XYZN file not found',0,'X2AT') CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD') CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ) WRITE (IATOMS, 110) CCODE 110 FORMAT (5HATOMS, 5X, A6) DO 140 I=1,NTYPE CALL ATOMIZ (CELATY(I), NLET(I), IZTYPA(I)) 140 CONTINUE CALL ATSHEL (IXYZN, ATXYZ, ATNAME, IZAT, MAXAT, NAT) IF (NAT .LE. 0) GOTO 250 CALL KERNZA( 0.0, HU, NAT) DO 150 I =1, NAT IF (ATXYZ(5,I) .LT. 0.0) HU(I) = ABS(ATXYZ(5,I)) 150 CONTINUE BCRES = 0.0 CALL ATOMST (2, ATXYZ, NAT, KEYT) IF (KEYT .EQ. 3) CALL ATBEQ (ATXYZ, B, NAT) CALL ATOMOC (2, ATXYZ, ITAT, NAT) DO 210 I=1,NAT ISF = ' ' DO 160 J=1,NTYPE 160 IF (IZAT(I).EQ.IZTYPA(J)) GOTO 180 WRITE (IPR1, 170) ATNAME(I) 170 FORMAT (' ATOM ' , A6, ' not found in CRYSDA file,', + ' ISFAC = X was assigned ') ISF = 'X' 180 NN = 10 IF (ATXYZ(6,I) .LE. 0.) NN = 5 IF (NN .EQ. 5) B(I) = ATXYZ(5,I) IF (HU(I) .LE. 0.0005) THEN BCRES = B(I) ELSE B(I) = HU(I) * BCRES ENDIF WRITE (IATOMS, 190) ATNAME(I), (ATXYZ(K,I),K=1,4), B(I), ISF 190 FORMAT ('ATOM', 1X, A6, 1X, 5F10.5, 4X, A1) IF (NN.EQ.5) GOTO 210 WRITE (IATOMS, 200) (ATXYZ(K,I), K=5,10) 200 FORMAT ('BIJ', 9X, 6F10.5) 210 CONTINUE WRITE (IATOMS, 230) 230 FORMAT ('END') CALL FILCLO (IXYZN, 'KEEP') CALL FILCLO (IATOMS, 'KEEP') WRITE (IPR1, 240) NAT 240 FORMAT (' Number of atoms input is', I5 ) RETURN 250 CALL KERROR ('XYZN file incorrect',0,'X2AT') RETURN END SUBROUTINE ATSHEL (IXYZN, ATXYZ, ATNAME, IZAT, MAXAT, NAT) PARAMETER (NSLOT = 10) DIMENSION ATXYZ(NSLOT,MAXAT), IZAT(MAXAT) CHARACTER * 6 ATNAME(MAXAT) 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 L(69) DATA LMAX / 69 / DATA L / 'SHEL', 'DUMM', 'SFAC', 'FVAR', 'BLOC', + 'WGHT', 'AFIX', 'DFIX', '= ', 'ANIS' , * 'ACTA', 'BASF', 'BIND', 'BOND', 'BUMP', 'CELL', 'CGLS', 'CHIV', * 'CONF', 'CONN', 'DAMP', 'DEFS', 'DELU', 'DISP', 'EADP', 'END ', * 'EQIV', 'EXTI', 'EXYZ', 'FEND', 'FLAT', 'FMAP', 'FRAG', 'FREE', * 'GRID', 'HFIX', 'HKLF', 'ISOR', 'L.S.', 'LATT', 'LAUE', 'LIST', * 'MERG', 'MOLE', 'MORE', 'MOVE', 'MPLA', 'OMIT', 'PART', 'PLAN', * 'REM ', 'RESI', 'RTAB', 'SADI', 'SAME', 'SIMU', 'SIZE', 'SLIM', * 'SPEC', 'SUMP', 'SWAT', 'SYMM', 'TEMP', 'TIME', 'TITL', 'TWIN', * 'UNIT', 'WPDB', 'ZERR'/ CALL ATOMIS (IXYZN, L, LMAX, ATXYZ, ATNAME, IZAT, MAXAT, NAT) RETURN END SUBROUTINE ATOMIS (IXYZN, L, LMAX, ATXYZ, ATNAME, IZAT, MAXAT,NAT) CHARACTER * 6 L(LMAX) PARAMETER (NSLOT = 10) DIMENSION ATXYZ(NSLOT,MAXAT), IZAT(MAXAT) CHARACTER * 6 ATNAME(MAXAT) 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)) DIMENSION FVAR(99) DATA MFVAR / 99 / DATA I / 0 / CALL KERNZA (0.0, FVAR, MFVAR) IFVAR = 0 KELAST = 0 KEACT = 0 NAT = 0 100 CALL KERIFF (IXYZN, L, LMAX, LEND) IF (LEND.NE.0) GOTO 190 KELAST = KEACT KEACT = 0 IFNUM = 1 IF (KELAST.NE.9) GOTO 120 I1 = 1 110 I = I + 1 IF (I .GT. NSLOT) GOTO 180 ATXYZ(I,NAT) = FNUM(I1) I1 = I1 + 1 GOTO 110 120 IF (CHIN(1:4) .EQ. ' ') GOTO 100 IF (CHIN(1:3) .EQ. 'REM') GOTO 100 KEY1 = NLUSER(1) IF (KEY1 .GT. 10) GOTO 100 KEACT = 0 IF (NLIT.GT.1) KEACT = NLUSER(NLIT) IF (KEY1.NE.4) GOTO 160 IF (CHIN(73:80) .EQ. ' ') GOTO 129 IF (NFNUM .LT. 6) CALL KERROR(' FORMAT error on FVAR', 0, 'X2AT') READ (CHIN, 128) (FNUM(I), I=1,7) 128 FORMAT (10X, 7F10.5) NFNUM = 7 129 CONTINUE DO 130 I=1,NFNUM IF (I.GT.MFVAR) GOTO 140 130 FVAR(I+IFVAR) = FNUM(I) IFVAR = IFVAR + NFNUM GOTO 160 140 WRITE (IPR1,150) MFVAR 150 FORMAT (' TOO MANY FREE VARIABLES, MAXIMUN ', I2) GOTO 200 160 CONTINUE IF (KEY1 .GT. 0) GOTO 100 NAT = NAT + 1 IF (NAT.GT.MAXAT) CALL KERROR * ('Too many atoms on Shelx atoms file', 160, 'ATOMIS') CALL ATOMSH (IZAT(NAT), ISFAC) IF (IZAT(NAT).LE.0) GOTO 200 ATNAME(NAT) = LIT(1) CALL KERNZA (0., ATXYZ(4,NAT), NSLOT-3) I = 0 170 I = I + 1 I1 = I + 1 IF (I.LE.3 .AND. NCOLN(I1).LE.0) GOTO 200 IF (I.GT.3 .AND. NCOLN(I1).LE.0) THEN I = I - 1 GOTO 180 ENDIF ATXYZ(I,NAT) = FNUM(I1) IF (I.LT.NSLOT) GOTO 170 180 CONTINUE IF (KEACT.EQ.9) GOTO 100 NVAR = I IF (NVAR .GT. 10) NVAR = 10 CALL ATOSHX (FVAR, MFVAR, NVAR, ATXYZ, MAXAT, NAT, KI) IF (KI.LT.0) GOTO 200 GOTO 100 190 IF (NAT.LE.0) CALL KERROR ('No atoms found', 190, 'ATOMIS') RETURN 200 CALL KERROR ('Error in SHELX atom record', 0, 'ATOMIS') END SUBROUTINE ATOMSH (IZ, ISFAC) 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 IZ = 0 IF (NFDOL(1).GE.0) RETURN I = NCOLL(1) CALL ATOMIZ (CHIN(I:I+1), NLET, IZ) IF (IZ.LE.0) RETURN I = NLET + 1 IF (I.GT.5) GOTO 150 IF (CHIN(4:4).NE.' ' .AND. CHIN(5:5).NE.' ') GOTO 150 IF (I.EQ.5) GOTO 140 IF (CHIN(3:3).EQ.' ') CHIN(3:4) = CHIN(4:4) IF (CHIN(2:2).EQ.' ') CHIN(2:4) = CHIN(3:4) IF (CHIN(1:1).EQ.' ') CHIN(1:4) = CHIN(2:4) CALL ATOMIZ (CHIN(1:2), NLET, I) IF (I.NE.IZ) GOTO 150 I = NLET + 1 IF (CHIN(I:I).EQ.' ') GOTO 140 CALL KERC2I (CHIN(I:I), NEN) IF (NEN.EQ.37 .OR. NEN.EQ.38) NEN = 0 IF (NEN.EQ.45 .OR. NEN.EQ.46) NEN = 0 IF (NEN.LT.0 .OR. NEN.GT.9) GOTO 150 CALL KERINB (LIT(32), 1) 140 IF (NFDOT(1).NE.1) GOTO 150 ISFAC = NINT (FNUM(1)) IF (ISFAC.LE.0) GOTO 150 RETURN 150 IZ = 0 RETURN END SUBROUTINE ATOSHX (FVAR, MFVAR, NVAR, ATXYZ, MAXAT, NAT,KI) PARAMETER (NSLOT = 10) DIMENSION ATXYZ(NSLOT,MAXAT) DIMENSION FVAR(MFVAR) DO 150 I=1,NVAR IF (ABS(ATXYZ(I,NAT)).LT.5.0) GOTO 150 IF (ATXYZ(I,NAT).GT.10.0) GOTO 100 IF (ATXYZ(I,NAT).LT.-10.0) GOTO 110 ATXYZ(I,NAT) = ATXYZ(I,NAT) - 10.0 GOTO 150 100 IX = IFIX( ATXYZ(I,NAT) / 10.0 + .05) VALP = ATXYZ(I,NAT) - FLOAT(IX*10) IF (IX.GT.1) GOTO 130 ATXYZ(I,NAT) = ATXYZ(I,NAT) - 10.0 GOTO 150 110 IX = IFIX( ABS(ATXYZ(I,NAT)) / 10.0 + .05) VALN = ATXYZ(I,NAT) + FLOAT(IX*10) IF (IX.LE.1) GOTO 160 IF (ABS(FVAR(IX)).LT.0.000001) GOTO 160 ATXYZ(I,NAT) = (FVAR(IX)-1.0) * VALN IF (ABS(FVAR(IX)).LT.5.0) GOTO 150 IF (FVAR(IX).GT.10.0) GOTO 120 ATXYZ(I,NAT) = FVAR(IX) - 10.0 ATXYZ(I,NAT) = (ATXYZ(I,NAT) - 1.0) * VALN GOTO 150 120 ATXYZ(I,NAT) = FVAR(IX) - 10.0 ATXYZ(I,NAT) = (ATXYZ(I,NAT) - 1.0) * VALN GOTO 150 130 CONTINUE IF (ABS(FVAR(IX)).LT.0.000001) GOTO 160 ATXYZ(I,NAT) = FVAR(IX) * VALP IF (ABS(FVAR(IX)).LT.5.0) GOTO 150 IF (FVAR(IX).GT.10.0) GOTO 140 ATXYZ(I,NAT) = (10.0 - FVAR(IX)) * VALP GOTO 150 140 ATXYZ(I,NAT) = (FVAR(IX) - 10.0) * VALP 150 CONTINUE KI = 1 RETURN 160 KI = -1 RETURN END SUBROUTINE FR2BIN CALL FR2BIX RETURN END SUBROUTINE FR2BIX 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 (IDDJ, IFILE( 1)) EQUIVALENCE (IPR1, IFILE( 6)) EQUIVALENCE (LIS1, IFILE( 7)) EQUIVALENCE (IFREF, IFILE(11)) EQUIVALENCE (IBIN, IFILE(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 DIMENSION HKL(3) DIMENSION FITEMS(3) PARAMETER (MAXBUF = 198) DIMENSION BUFO(MAXBUF) EQUIVALENCE (FITEMS(1),HCODE), (FITEMS(2),FOBS), (FITEMS(3),SIG) CHARACTER * 6 FILENM, BINNM CHARACTER * 1 IE CALL FILINQ (IDDJ, 'DDJOB', 'FORMATTED', 'INPUT', KEND) IF (KEND .EQ. 0) THEN CALL KERINA ( IDDJ, LIT(32), 1, LEND) FILENM = LIT(4) CALL FILCLO (IDDJ, 'KEEP') GOTO 110 ENDIF CALL FILCLO (IDDJ, 'KEEP') 100 WRITE (IPR1, FMT = '(/, *'' Execution of program FR2BIN for file transformation:'',/, *'' Please, give input FREF type (e.g. FREFA, FREFLP, .. ): '')') CALL KETERM (0, 1, KEND) IF (KEND .LT. 0) GOTO 100 FILENM = LIT(1) 110 IF (FILENM(1:4) .NE. 'FREF') GOTO 100 BINNM = 'BIN' BINNM(4:5) = FILENM(5:6) WRITE (CHOUT, 114) FILENM, BINNM 114 FORMAT (' Convert a ', A6, ' file into a ', A6, ' file.') CALL FILINQ (IFREF, FILENM , 'FORMATTED', 'INPUT', KINQ) IF (KINQ.EQ.-1) CALL KERROR (' No FREFxx file ', 0, 'FR2BIN') READ (IFREF, FMT = '(A28)' ) CHIN(1:28) WRITE( LIS1, FMT = '('' Input file header '',A28)' ) CHIN(1:28) IF (CHIN(1:4) .NE. 'FREF') CALL KERROR * (' Input file is not a FREF file', 0, 'FR2BIN') CALL KERINB (LIT(32),1) CCODE = LIT(2) IFI = 1 IF (CHIN(18:20) .EQ. 'FRI') IFI = 2 IF (CHIN(18:20) .EQ. 'BIJ') IFI = 3 IAB = 1 IF (CHIN(22:24) .EQ. 'EMP') IAB = 2 IDI = 1 IF (CHIN(26:28) .EQ. 'DIF') IDI = 2 BUFO(5) = FLOAT (IAB + IFI * 10 + IDI * 100) NIT = 3 CALL BINOFF (5, IBIN, BINNM, FITEMS, NIT, BUFO, NEND) NREF = 0 240 READ (IFREF, 250) IE, HKL, JC, FOBS, SIG 250 FORMAT (A1, 3F3.0 ,I2, F9.2, F7.2) IF (IE.EQ.'E') GOTO 270 CALL HKLC1 (HKL, HCODE) NREF = NREF + 1 CALL BINOFF (0, IBIN, BINNM, FITEMS, NIT, BUFO, NEND) GOTO 240 270 CALL BINOFF (-1, IBIN, BINNM, FITEMS, NIT, BUFO, NEND) WRITE (LIS1, 300) NREF 300 FORMAT(' Number of reflections: ', I14,/) CALL FILCLO (IFREF, 'KEEP') CALL FILCLO (IBIN, 'KEEP') RETURN END SUBROUTINE BIN2FR CALL BIN2FX (ISTOP) IF (ISTOP .NE. 0) CALL KERROR * ('Check stars (****) in output FREF-file',0,'BIN2FR') END SUBROUTINE BIN2FX (ISTOP) 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 (IDDJ, IFILE(1)), (IPR1, IFILE(6)) EQUIVALENCE (LIS1, IFILE(7)), (IBIN, IFILE(11)) EQUIVALENCE (IFREF, IFILE(12)) DIMENSION HKL(3), IHKL(3) DIMENSION FITEMS(3) PARAMETER (MAXBUF = 198) DIMENSION BUFI(MAXBUF) EQUIVALENCE (FITEMS(1),HCODE), (FITEMS(2),FOBS), (FITEMS(3),SIG) CHARACTER * 6 FILENM, FREFNM CHARACTER * 3 FI(3), FA(3), FD(3) DATA FI /' ','FRI','BIJ'/ DATA FA /' ','EMP',' '/ DATA FD /' ','DIF',' '/ DATA SIGM / 0.0 / ISTOP = 0 CALL FILINQ (IDDJ, 'DDJOB', 'FORMATTED', 'INPUT', KEND) IF (KEND .EQ. 0) THEN CALL KERINA ( IDDJ, LIT(32), 1, LEND) FILENM = LIT(4) CALL FILCLO (IDDJ, 'KEEP') GOTO 110 ENDIF CALL FILCLO (IDDJ, 'KEEP') 100 WRITE (IPR1, FMT = '(/, * '' Execution of program BIN2FR for file transformation:'',/, * '' Please, give input BIN- type (e.g. BINA, BINLP, .. ): '')') CALL KETERM (0, 1, KEND) IF (KEND .LT. 0) GOTO 100 FILENM = LIT(1) 110 IF (FILENM(1:3) .NE. 'BIN') GOTO 100 FREFNM = 'FREF' FREFNM(5:6) = FILENM(4:5) WRITE (CHOUT, 114) FILENM, FREFNM 114 FORMAT (' Convert a ', A6, ' file into a ', A6, ' file.') CALL FILINQ (IFREF, FREFNM, 'FORMATTED', 'OUTPUT', KINQ) NIT = 3 CALL BINIFF (6, IBIN, FILENM, FITEMS, NIT, BUFI, NEND) CCODE = CHIN(7:12) CHIN = ' ' CHIN(1:6) = FREFNM CHIN(8:13) = CCODE IB = NINT(BUFI(5)) IDI = IB/100 IF (IDI.LT.1 .OR. IDI.GT.3) GOTO 117 CHIN(26:28) = FD(IDI) IB = IB - IDI * 100 IFI = IB/10 IF (IFI.LT.1 .OR. IFI.GT.3) GOTO 117 CHIN(18:20) = FI(IFI) IFA = (MOD(IB,10)) IF (IFA.LT.1 .OR. IFA.GT.3) GOTO 117 CHIN(22:24) = FA(IFA) 117 WRITE (LIS1, FMT = '('' Output file header '',A28)' ) CHIN(1:28) WRITE (IFREF, FMT = '(A28)' ) CHIN(1:28) NREF = 0 240 CALL BINIFF (0, IBIN, FILENM, FITEMS, NIT, BUFI, NEND) IF (NEND .LT. 0) GOTO 270 NREF = NREF + 1 CALL HKLC1U (HCODE, HKL) CALL KERF2I (HKL, IHKL, 3) JC = 0 IF (SIG .LT. 0.0) THEN SIG = ABS(SIG) JC = 2 ENDIF IF (FOBS .LT. 5.0 * SIG) JC = 2 CALL FREF9F(IFREF, IHKL(1), IHKL(2), IHKL(3), JC, FOBS, SIG, KEND) IF (KEND .EQ. 1) THEN WRITE (CHOUT, 260) IHKL, FOBS, SIGM 260 FORMAT (' Fobs or sig for refl.', 3I3, ' to big ', * 'Fobs =',F10.0,' sig =',F10.0) CALL SHOUT ISTOP = 5 ENDIF GOTO 240 270 WRITE (IFREF, 280) 280 FORMAT ('E') WRITE (LIS1, 300) NREF 300 FORMAT (' Number of reflections (output): ', I14,/) CALL FILCLO (IFREF, 'KEEP') CALL FILCLO (IBIN, 'KEEP') RETURN END SUBROUTINE PRIFC CALL FOFC2 (ISTOP) IF (ISTOP .NE. 0) CALL KERROR * ('Check stars (****) in output FREF-file',0,'PRIFC') RETURN END SUBROUTINE FOFC2 (ISTOP) 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)) EQUIVALENCE ( LIS1, IFILE( 7)), ( LIS2, IFILE( 8)) EQUIVALENCE (IBINFO, IFILE(11)), (IBINFC, IFILE(13)) EQUIVALENCE (IFREF, IFILE(12)), (ICRYS, IFILE(3)) PARAMETER (MAXBUF = 198) DIMENSION BUFFO(MAXBUF), BUFFC(MAXBUF) DIMENSION HKL(3), IHKL(3), FITFO(3), FITFC(2) EQUIVALENCE (HCODE, FITFO(1)), (FOBS, FITFO(2)), * ( SIG, FITFO(3)) EQUIVALENCE ( FCAL, FITFC(1)), (PH, FITFC(2)) CHOUT = '0Output PRInt FCalc to LIS2' CALL SHOUT CALL RDCRYS (ICRYS) NITFC = 2 NITFO = 3 IREF = 0 CALL BINIFF (1, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO) CALL BINIFF (1, IBINFC, 'BINFC', FITFC, NITFC, BUFFC, KENDFC) SCALE = BUFFC(18) WRITE(LIS2, FMT = '('' Scale applied to Fobs: '', F9.4)') SCALE WRITE(LIS2, FMT = '( * '' h k l Fobs sigma Fcalc phase sin(th)/L''/)') 200 CALL BINIFF (0, IBINFO, 'BINFO', FITFO, NITFO, BUFFO, KENDFO) IF (KENDFO.LT.0) GOTO 300 IREF = IREF + 1 CALL BINIFF (0, IBINFC, 'BINFC', FITFC, NITFC, BUFFC, KENDFC) CALL HKLC1U (HCODE, HKL) CALL HKLSTL (HKL, STL, STL2) CALL KERF2I (HKL, IHKL, 3) FOBS = FOBS * SCALE SIG = SIG * SCALE WRITE(LIS2, FMT = '( 1X, 3I3, 2X, 2(F9.3, F7.2), F9.5)') * IHKL, FOBS, SIG, FCAL, PH, STL GOTO 200 300 ISTOP = 0 WRITE(LIS2, FMT = '(1X)') WRITE(CHOUT, FMT = '('' Number of reflections '', I5)') IREF CALL SHOUT CALL FILCLO (IBINFO, 'KEEP') CALL FILCLO (IBINFC, 'KEEP') RETURN END SUBROUTINE FREF9F (IFIL, IH, IK, IL, JC, FF, SIG, KEND) CHARACTER * 1 CH(9) DATA CH /' ','2','3','4','5','6','7','8','9'/ KEND = 0 K = JC IF (JC.EQ.0) K = 1 IF (JC.LT.0 .OR. JC.GT.9) K = 9 IF (FF .LE. 9999.9 .AND. SIG .LE. 999.9) THEN WRITE (IFIL,161) IH,IK,IL, CH(K), FF, SIG 161 FORMAT (1X,3I3,1X,A1,F9.4,F7.3) ELSE WRITE (IFIL,162) IH,IK,IL, CH(K), FF, SIG 162 FORMAT (1X,3I3,1X,A1,F9.2,F7.2) IF (FF .GT. 999999.99 .OR. SIG .GT. 9999.99) KEND=1 ENDIF RETURN END SUBROUTINE BIJVOE 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 (IXYZN, IFILE(1) ), (IATOMS, IFILE(2) ) EQUIVALENCE (IRD, IFILE(5) ), (IPR1, IFILE(6) ) EQUIVALENCE (LIS1, IFILE(7) ), (LIS2, IFILE(8) ) CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINIA) CALL FILINQ (IXYZN, 'XYZN', 'FORMATTED', 'INPUT', KINIX) IF (KINIA .NE. 0 .AND. KINIX .NE. 0) * CALL KERROR( ' No ATOMS or XYZN file present ', 0, 'BIJVOE') IF (KINIA .EQ. 0 .AND. KINIX .NE. 0) GOTO 200 IF (KINIA .NE. 0 .AND. KINIX .EQ. 0) GOTO 150 110 WRITE (IPR1, 112) 112 FORMAT (' Select one of the atomic input files: XYZN or ATOMS', * ' (X/A)') CALL KETERM (0, 1, KEND) IF (KEND .LT. 0) GOTO 110 IF (LIT(1)(1:1) .EQ. 'A') GOTO 190 IF (LIT(1)(1:1) .NE. 'X') GOTO 110 150 CALL X2AT 190 CALL FILCLO (IXYZN, 'KEEP') 200 CALL MERBIB CALL FCALCB CALL BIJVOX RETURN END SUBROUTINE MERBIB 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 (ICRYS, IFILE(3)) EQUIVALENCE (LIS1, IFILE( 7)) EQUIVALENCE (LIS2, IFILE( 8)) EQUIVALENCE (IFREF , IFILE(11)) EQUIVALENCE (IHKL, IFILE(11)) EQUIVALENCE (IBINFO, IFILE(12)) EQUIVALENCE (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 PARAMETER (MAXA=6000, FMAXA=6000.) COMMON / / AREF(7, MAXA) DIMENSION HKL(3), HKL2(3), HMAX(3), HMIN(3) DIMENSION FITFO(3), FITFOB(5) EQUIVALENCE (FITFO(1),HCODEX), (FITFO(2),FOBS), (FITFO(3),SIG) EQUIVALENCE (FITFOB(1),HCODEF), (FITFOB(2),FOBSA), + (FITFOB(3),SIGA), (FITFOB(4),FOBSB), (FITFOB(5),SIGB) PARAMETER (MAXBUF = 198) DIMENSION BUFS(MAXBUF), BUFO(MAXBUF) PARAMETER (MAXP = 500) LOGICAL FRIE CHARACTER *1 IE DATA FRIE /.FALSE./ DATA DF1MIN, DF2MIN / 0., 0. / CALL KERNZA ( 9999., HMIN, 3) CALL KERNZA ( -9999., HMAX, 3) STLMAX = 0.0 HCODMI = 4.0 * 256.**3 HCODMA = - HCODMI CALL RDCRYS (ICRYS) WRITE (LIS1, FMT='(66X, A6)') CCODE WRITE (LIS2, FMT='(66X, A6)') CCODE WRITE (LIS2, FMT='(1X, ''SUBROUTINE MERBIB'')') IF (ICENT.EQ.2) CALL KERROR (' Space group is centrosymmetric, no +further calculations', 0, 'MERBIB') WRITE (LIS1,FMT='('' Wavelength of radiation'',41X,F7.5)') WAVE WRITE (LIS2,FMT='('' Wavelength of radiation'',41X,F7.5)') WAVE NIT = 3 CALL BINOFF (4, IBINS, 'BINS', FITFO, NIT, BUFS, NEND) NREF = 0 NNREF = 0 MREF99 = 0 CALL FILINQ (IFREF, 'FREFB', 'FORMATTED', 'INPUT', KINQ) IF (KINQ .NE. 0) THEN CALL FILINQ (IFREF, 'FREF', 'FORMATTED', 'INPUT', KINQA) IF (KINQA .NE. 0) * CALL KERROR ('No FREF or FREFB file found', 0, 'MERBIB') ENDIF CHIN = ' ' READ (IFREF, FMT='(A28)') CHIN(1:28) WRITE (LIS1, 124) CHIN(1:28) 124 FORMAT (' Input reflection file is:', 3X, A28) CALL KERINB (LIT, 1) IF (KINQ .EQ. 0) THEN IF (LIT(1) .NE. 'FREFB') CALL KERROR * ('Header of input file is not = FREFB =' , 0, 'MERBIB') IF (LIT(2) .NE. CCODE) CALL KERROR * ('Input file has incorrect CCODE', -6, 'MERBIB') ENDIF 130 READ (IFREF, 131) IE, HKL, JC, FOBS, SIG 131 FORMAT (A1, 3F3.0 ,I2, F9.2, F7.2) IF(IE .EQ. 'E') GOTO 200 CALL HKLAXT (HKL, KEND) IF (KEND.LT.0) GOTO 130 CALL HKLEXT (HKL, KEND) IF (KEND.LT.0) GOTO 130 MREF99 = MREF99 + 1 IF (ABS (HKL(1)) .GT. 99. .OR. ABS (HKL(2)) .GT. 99. .OR. * ABS (HKL(3)) .GT. 99. ) GOTO 130 DO 143 I=1,3 143 HKL2(I)= -HKL(I) CALL HKLEXS (FRIE, HKL , HCODE1) CALL HKLEXS (FRIE, HKL2, HCODE2) IF (ILAUE .GE. 6 .AND. ILAUE .LE. 12) THEN H99 = AMAX1 ( ABS(HCODE1), ABS(HCODE2) ) IF (H99 .GT. 3920000.) GOTO 130 ENDIF NREF = NREF + 1 IF (NINT(HCODE1) .EQ. NINT(HCODE2)) GOTO 130 IF (HCODE1.GT.HCODE2) THEN HCODEX = HCODE1 ELSE HCODEX = -HCODE2 ENDIF HCODEF = ABS(HCODEX) FOBS = AMAX1 (FOBS, SIG / 1000. , 0.001) SIG = AMAX1 (SIG, FOBS / 1000. , 0.001) IF (JC .EQ. 2) SIG = AMAX1(FOBS/6.0, SIG) SIG = SIG * 2. * FOBS FOBS = FOBS**2 HCODMI = AMIN1(HCODMI, HCODEF) HCODMA = AMAX1(HCODMA, HCODEF) CALL HKLC1U (HCODEF, HKL) DO 150 I =1,3 HMAX(I) = AMAX1 (HKL(I),HMAX(I)) 150 HMIN(I) = AMIN1 (HKL(I),HMIN(I)) CALL HKLSTL (HKL, STL, STL2) STLMAX = AMAX1(STLMAX, STL) NNREF = NNREF + 1 CALL BINOFF (0, IBINS, 'BINS', FITFO, NIT, BUFS, NEND) GOTO 130 200 CALL FILCLO (IFREF, 'KEEP') CALL BINOFF (-1, IBINS, 'BINS', FITFO, NIT, BUFS, NEND) WRITE (LIS1, 301) NREF WRITE (LIS2, 301) NREF 301 FORMAT(' Number of reflections from input file ', 27X, I6) MREF99 = MREF99 - NREF IF (MREF99 .GT. 0) WRITE (LIS1, 303) MREF99 303 FORMAT (' Number of relections with hkl exceeding 99: ', I7/ * ' WARNING: these reflections are not used in BIJVOET!'/) BUFO(5) = 0. BUFO(6) = STLMAX CALL KERNZA (0., BUFO(7), 3) CALL KERNAB (HMAX, BUFO(10), 3) CALL KERNAB (HMIN, BUFO(13), 3) NITB = 5 CALL FILINQ (IBINFO, 'BINFO', 'UNFORMATTED', 'TEST', KINQ) IF (KINQ .EQ. 0) THEN CALL FILCLO (IBINFO, 'DELETE') WRITE (CHOUT, FMT = '('' The file BINFO is erased'')') CALL SHOUT2 ENDIF CALL BINOFF (15, IBINFO, 'BINFO', FITFOB, NITB, BUFO, NENDO) CALL BINIFF (4, IBINS, 'BINS', FITFO, NIT, BUFS, NENDI) CALL HKLC2I (HMIN, HMAX) CALL HKLC1U (HCODMI, HKL) CALL HKLC2 (HKL, ACODMI) NREW = 0 IPAIR = 0 KPAIR = 0 SDF1 = 0. SDF2 = 0. NDF1 = 0 NDF2 = 0 NDF3 = 0 NDF4 = 0 310 AF = ACODMI - 1.1 CALL HKLC2U (ACODMI + FMAXA - 1., HKL) CALL HKLC1 (HKL, HCODEL) CALL KERNZA (0.0, AREF, 7 * MAXA) 320 CALL BINIFF (0, IBINS, 'BINS', FITFO, NIT, BUFS, NENDI) IF (NENDI .LT. 0 ) GOTO 325 HCODEF = ABS(HCODEX) IF (HCODEF.LT.HCODMI .OR. * HCODEF.GT.HCODEL) GOTO 320 CALL HKLC1U (HCODEF, HKL) CALL HKLC2 (HKL, ACODE) IA = IFIX (ACODE - AF) AREF(1,IA) = HCODEF IF (HCODEX.LT.0.1) GOTO 323 AREF(2,IA) = AREF(2,IA) + 1. AREF(3,IA) = AREF(3,IA) + FOBS AREF(4,IA) = AREF(4,IA) + SIG GOTO 320 323 AREF(5,IA) = AREF(5,IA) + 1. AREF(6,IA) = AREF(6,IA) + FOBS AREF(7,IA) = AREF(7,IA) + SIG GOTO 320 325 IF (NREW .GT. 0) GOTO 330 NREW = NREW + 1 IF (NNREF .LT. 500) GOTO 330 DO 328 I = 1,MAXA IF (AREF(2,I) .LE. 0.1 .OR. AREF(5,I).LE.0.1) GOTO 328 IPAIR = IPAIR + 1 FOBSA = SQRT( AREF(3,I) / AREF(2,I) ) SIGA = AREF(4,I) / AREF(2,I)**1.5 / (2. * FOBSA) FOBSB = SQRT( AREF(6,I) / AREF(5,I) ) SIGB = AREF(7,I) / AREF(5,I)**1.5 / (2. * FOBSB) SDF1 = SDF1 + ABS(FOBSA - FOBSB) / (0.5 * (FOBSA + FOBSB)) SDF2 = SDF2 + ABS(FOBSA - FOBSB) / SQRT( SIGA**2 + SIGB**2) 328 CONTINUE DF1MIN = 0.25 * SDF1 / FLOAT(IPAIR) DF2MIN = SDF2 / FLOAT(IPAIR) DF2MIN = 0.5 * (DF2MIN + 1.0) IPAIR = 0 330 DO 340 I = 1,MAXA IF (AREF(2,I) .LE. 0.1 .OR. AREF(5,I).LE.0.1) GOTO 340 IPAIR = IPAIR + 1 HCODEF = AREF(1,I) FOBSA = SQRT( AREF(3,I) / AREF(2,I) ) SIGA = AREF(4,I) / AREF(2,I)**1.5 / (2. * FOBSA) FOBSB = SQRT( AREF(6,I) / AREF(5,I) ) SIGB = AREF(7,I) / AREF(5,I)**1.5 / (2. * FOBSB) IF (NNREF .LT. 500) GOTO 332 DF1 = ABS (FOBSA - FOBSB) / (0.5 * (FOBSA + FOBSB)) DF2 = ABS(FOBSA - FOBSB) / SQRT( SIGA**2 + SIGB**2) IF (DF1.LT.DF1MIN) NDF1 = NDF1 + 1 IF (DF2.LT.DF2MIN) NDF2 = NDF2 + 1 IF (DF1.LT.DF1MIN .AND. DF2 .LT. DF2MIN) NDF3 = NDF3 + 1 IF (DF1.LT.DF1MIN) GOTO 340 IF (DF2.LT.DF2MIN) GOTO 340 332 CALL BINOFF (0, IBINFO, 'BINFO', FITFOB, NITB, BUFO, NENDO) KPAIR = KPAIR + 1 340 CONTINUE IF (HCODEL.GE.HCODMA) GOTO 350 ACODMI = ACODMI + FMAXA 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', FITFOB, NITB, BUFO, NENDO) IF (IPAIR.EQ.0) CALL KERROR (' No Bijvoet pairs found, no further *calculations', 0, 'MERBIB') WRITE (LIS1, 352) IPAIR WRITE (LIS2, 352) IPAIR 352 FORMAT (' Number of Bijvoet pairs ', 41X, I6) IF (NNREF .LT. 500) GOTO 360 WRITE (LIS2, FMT='(/,'' Selection of Bijvoet pairs on'', * '' dFo = Fo(h) - Fo(-h)'',/, 3X, * '' with sig(dFo) = sqrt(sig(Fo(h))**2 + sig(Fo(-h))**2)'', * /, 29X, ''rejection criterion'', 9X, ''number of pairs'')') WRITE (LIS2, FMT='( * '' abs(dFo)/(0.5*(Fo(h)+Fo(-h)) <'', F6.3, 18X, I6)') * DF1MIN, NDF1 WRITE (LIS2, FMT='( * '' abs(dFo)/sig(dFo)'',20X,''<'',F6.3,18X,I6)') DF2MIN, NDF2 WRITE (LIS2, FMT='( * '' abs(dFo)/(0.5*((Fo(h)+Fo(-h))) <'',F6.3, '' and'',/, * '' abs(dFo)/sig(dFo)'',20X,''<'', F6.3, 18X, I6)') * DF1MIN, DF2MIN, NDF3 WRITE (LIS2, 354) KPAIR 354 FORMAT (' Number of Bijvoet pairs selected on dFo', 26X, I6) IF (KPAIR .GT. MAXP) WRITE (LIS2, 357) MAXP 357 FORMAT (' Number of pairs used is limited to', 31X, I6) 360 CALL FILCLO (IBINS, 'DELETE') RETURN END SUBROUTINE FCALCB 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)), (ICRYS, IFILE(3)) EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (IBINFO, IFILE(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 /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 (MAXP = 500, MAXAT = 993, MAXSCS = 3000) 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, * PAIRS (6, MAXP), MPAIR, SCS(2,MAXSCS) DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) CHARACTER *6 ATNAME(MAXAT) DIMENSION FITFOB(5), FITB(6) EQUIVALENCE (FITFOB(1),HCODEF), * (FITFOB(2), FOBSA), (FITFOB(3), SIGA), * (FITFOB(4), FOBSB), (FITFOB(5), SIGB) EQUIVALENCE (FPF, PHIP) PARAMETER (MAXBUF = 198) DIMENSION BUFO(MAXBUF) DATA ST1, ST2, ST6, ST4, ST5, STO, STC / 0.,0.,0.,0.,0.,0.,0./ FNSYMM = FLOAT (NSYMM) FICENT = FLOAT (ICENT) CALL KERNZA (0., PAIRS, 6*MAXP) WRITE (LIS2, FMT='(/,1X, ''SUBROUTINE FCALCB'',/)') CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ) IF (KINQ .NE. 0) CALL KERROR ('No ATOMS file found', 0, 'FCALCB') CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT) CALL ATOMPR (LIS2, 7, ATXYZ, ATNAME, IZAT, NAT) CALL FILCLO (IATOMS, 'KEEP') WRITE (LIS1, 115) NAT 115 FORMAT (' Number of atoms from input file', I40) IF (KEYT.EQ.1) CALL KERROR * ('No temp.factors given: no further calculations', 0, 'FCALCB') CHOUT = ' Atoms have mixed/anisotropic temperature factors ' IF (KEYT.EQ.2) CHOUT = * ' Atoms have individual isotropic temperature factors' CALL SHOUT2 BDFT = 0. BDFN = 0. DO 110 I=1,NTYPE CALL RDCRYB(ICRYS, 'ELEM ', KEND) IF (KEND .LE. 0) CALL KERROR ('Error in CRYSDA file', 0, 'FCALCB') READ (CHIN, FMT='(10X, 2X, I8)') IZTYPE(I) CALL RDCRYX (ICRYS, 'SFAC ', SFAC(1,I), 13) BDFT = BDFT + CELALL(I) * SFAC(11,I)**2 BDFN = BDFN + CELALL(I) * IZTYPE(I)**2 110 CONTINUE BDF= SQRT(BDFT / BDFN) WRITE (LIS2, FMT='(/,'' Anomalous scattering fraction '', * ''of the structure '' , /, * 3X, '' sqrt(sum(Df"**2) / sum(Z**2)) ='', 29X, F8.5)') BDF NPAIR = 0 NITB = 5 CALL BINIFF (1, IBINFO, 'BINFO', FITFOB, NITB, BUFO, NENDI) STLMAX = BUFO(6) CALL FCALCI (KEYT, ATXYZ, IZAT, ITAT, NAT) CALL FILCLO (ICRYS, 'KEEP') MPAIR = 0 SUMDFC = 0. SUMFC = 0. SUMFO = 0. SUMSIG= 0. BQ1 = 0. BQ2 = 0. 200 CALL BINIFF (0, IBINFO, 'BINFO', FITFOB, NITB, BUFO, NENDI) IF (NENDI.LT.0) GOTO 220 NPAIR = NPAIR + 1 DFO = FOBSA - FOBSB SIG2 = SIGA**2 + SIGB**2 CALL HKLC1U (HCODEF, HKLX) CALL HKLSTL (HKLX, STL, STL2) CALL FCALB1 (KEYT, ATXYZ, ITAT, NAT) DFC = FP - FPF FITB(1) = ABS(DFC * DFO / SIG2) FITB(2) = HCODEF FITB(3) = DFC FITB(4) = DFO FITB(5) = SIG2 FITB(6) = (FP**2 + FPF**2) * 0.5 CALL SORTP(FITB, 6, PAIRS, MAXP, MPAIR) SUMDFC = SUMDFC + ABS(DFC) SUMFC = SUMFC + FP + FPF SUMFO = SUMFO + FOBSA + FOBSB IF (NPAIR .LE. MAXSCS) THEN SCS(1,NPAIR) = DFC SCS(2,NPAIR) = DFO SUMSIG= SUMSIG + SQRT(SIG2) ENDIF BQ1 = BQ1 + DFC**2 BQ2 = BQ2 + FITB(6) GOTO 200 220 CONTINUE CALL FILCLO (IBINFO, 'DELETE') DFCMIN = AMAX1 (0.005, 0.5 * SUMDFC/FLOAT(NPAIR) ) SC = SUMFC / SUMFO IF (NPAIR .GT. MAXSCS) NPAIR = MAXSCS SUMDDF = 0. DO 222 I=1,NPAIR SUMDDF = SUMDDF + ABS(ABS(SCS(1,I)) - ABS(SCS(2,I)*SC)) 222 CONTINUE SCSIG = SUMDDF / (SUMSIG * SC) BQ = SQRT (BQ1 / BQ2) WRITE (LIS2, FMT = '( / * '' Anomalous scattering '', * ''fraction for the selected Bijvoet pairs'', * /,3X, '' sqrt(sum(dFc**2) / sum(Fc)**2) ='', 28X, F8.5)') BQ WRITE (LIS2, FMT = '( /, * '' Scale factor'', / * 4X, ''SC = sumFc / sumFo = '', 39X, F8.4)') SC WRITE (LIS2,FMT='(4X,''SCSIG = sum||dFc|-|dFo||/sum sig(dFo) ='', * 19X, F10.4)') SCSIG IF (SCSIG .GT. 3.0) WRITE (LIS1, FMT='( * '' Warning: your SIG(Fobs) are probably underestimated!'')') WRITE (LIS2, FMT = '( / * '' Sorting Bijvoet pairs on |BT|=|dFc*dFo/sig(dFo)**2|'')') L = 0 DO 230 I=1,MPAIR IF (ABS(PAIRS(3,I)) .LT. DFCMIN) GOTO 230 L = L + 1 PAIRS(2,L) = PAIRS(2,I) PAIRS(3,L) = PAIRS(3,I) PAIRS(4,L) = PAIRS(4,I) * SC PAIRS(5,L) = PAIRS(5,I) * SC * SC PAIRS(6,L) = PAIRS(6,I) PAIRS(1,L) = PAIRS(3,L) * PAIRS(4,L) / PAIRS(5,L) 230 CONTINUE WRITE (LIS2, FMT = '(/, '' Selection of Bijvoet pairs on '', * ''dFc = Fc(h) - Fc(-h)'')') WRITE (LIS2, 231) DFCMIN, MPAIR -L 231 FORMAT (' Number of Bijvoet pairs with abs(dFc) <', * F6.3, 20X, I6) WRITE (LIS2, 232) L 232 FORMAT (' Number of Bijvoet pairs selected on dFc and dFo', * 18X, I6) MPAIR = L IF (NPAIR .GT. MPAIR) WRITE (LIS1, 241) MPAIR 241 FORMAT (' Number of Bijvoet pairs ', * 'selected for the calculation of B', I14) WRITE (LIS2, FMT='(/'' Statistics for '', I6, '' pairs '', * ''in batches of 25 '', /, * '' (a) average |Fc(h) - Fc(-h)|'',/ * '' (b) average |Fo(h) - Fo(-h)|'',/ * '' (d) average |Fo(h) - Fo(-h)| /sig(dFo)'')') MPAIR WRITE (LIS2, FMT='( * '' (e) percentage of positive values dFc'',/ * '' (f) percentage of positive values dFo'',/ * '' (g) SQRT (sum dFc**2 / sum Fc**2) '')') WRITE (LIS2, FMT='(/, 1X, * '' ----------cumulative----------------'', * '' -----individual badges------'', /, * '' a b d e f g a/b '', * '' a b d g a/b '')') SSSDFC = 0. SSSDFO = 0. SSUMDS = 0. STELC = 0. STELO = 0. ST5T = 0. ST5N = 0. SUMDFC = 0. SUMDFO = 0. SUMDS = 0. T5T = 0. T5N = 0. DO 460 I = 1, MPAIR FNFR = FLOAT(I) SUMDFC = SUMDFC + ABS(PAIRS(3,I)) SUMDFO = SUMDFO + ABS(PAIRS(4,I)) SUMDS = SUMDS + ABS(PAIRS(4,I)) / SQRT(PAIRS(5,I)) IF (PAIRS(3,I) .GT. 0.) STELC = STELC + 1. IF (PAIRS(4,I) .GT. 0.) STELO = STELO + 1. T5T = T5T + PAIRS(3,I)**2 T5N = T5N + PAIRS(6,I) IF (MPAIR.LT.25 .AND. I.EQ.MPAIR) THEN FMPAIR = FLOAT(MPAIR) T1 = SUMDFC / FMPAIR T2 = SUMDFO / FMPAIR T4 = SUMDS / FMPAIR T5 = SQRT (T5T / T5N) T6 = T1 / T2 GOTO 420 ENDIF IF (MOD(I, 25) .NE. 0) GOTO 460 T1 = SUMDFC / 25. T2 = SUMDFO / 25. T4 = SUMDS / 25. T5 = SQRT (T5T / T5N) T6 = T1 / T2 SSSDFC = SSSDFC + SUMDFC SSSDFO = SSSDFO + SUMDFO SSUMDS = SSUMDS + SUMDS ST5T = ST5T + T5T ST5N = ST5N + T5N ST1 = SSSDFC / FNFR ST2 = SSSDFO / FNFR ST4 = SSUMDS / FNFR STC = 100. * STELC / FNFR STO = 100. * STELO / FNFR ST5 = SQRT (ST5T / ST5N) ST6 = ST1 / ST2 420 WRITE (LIS2, 430) I, ST1, ST2, ST4, STC, STO, ST5, ST6, * T1, T2, T4, T5, T6 430 FORMAT (I4, 3F6.2, 2F4.0, F6.3, F6.3, 3F6.2, F6.3, F6.3 ) SUMDFC = 0. SUMDFO = 0. SUMDS = 0. T5T = 0. T5N = 0. 460 CONTINUE RETURN END SUBROUTINE FCALB1 (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 /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 EQUIVALENCE (LIS1, IFILE( 7)) EQUIVALENCE (LIS2, IFILE( 8)) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), MOLW, 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)) EQUIVALENCE (PHIP, FPF) DIMENSION FFF(10), ADTRIG(24) DATA ADTRIG / 24*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 A = 0.0 B = 0.0 AF = 0.0 BF = 0.0 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) 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 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 A = A + A1 * FFF(IJ) * TF B = B + B1 * SFAC(11,IJ) * TF AF = AF+ A2 * SFAC(11,IJ) * TF BF = BF+ B2 * FFF(IJ) * TF 250 CONTINUE FP = ASYMCL * SQRT((A + AF)**2 + (B + BF)**2) FPF= ASYMCL * SQRT((A - AF)**2 + (B - BF)**2) RETURN END SUBROUTINE SORTP (A, NA, B, NB, M) DIMENSION A(NA), B(NA, NB) IF (M .EQ. NB) THEN IF (A(1) .LE. B(1, NB)) RETURN GOTO 400 ENDIF M = M + 1 IF (M .EQ. 1) GOTO 482 400 DO 480 K = M, 2, -1 IF (A(1) .LE. B(1, K-1)) GOTO 483 CALL KERNAB (B(1, K-1), B(1, K), NA) 480 CONTINUE 482 K = 1 483 CALL KERNAB (A, B(1, K), NA) RETURN END SUBROUTINE BIJVOX 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)) EQUIVALENCE (LIS2, IFILE( 8)) PARAMETER (MAXP = 500, 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, * PAIRS (6, MAXP), MPAIR DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), SICO(1)) DIMENSION HKLT(3), IHKL(3) CHARACTER ADFO *1, ABTAV *1 DIMENSION MODA(5), MODB(5), MODC(5) DATA MODA / 3, 5, 8, 12, 18 / DATA MODB / 3, 8, 16, 28, 46 / DATA MODC / 30, 50, 90, 150, 230 / DATA MSEL, BSEL, SIGSEL, PSEL / 0, 0., 0., 0. / BTAV1 = 0. II = MIN0(25, MPAIR) DO 104 I = 1,II 104 BTAV1 = BTAV1 + ABS(PAIRS(1,I)) BTMIN1 = 2.*BTAV1/FLOAT(II) BTAV2 = 0. DO 106 I = 1,II 106 BTAV2 = BTAV2 + AMIN1(BTMIN1, ABS(PAIRS(1,I))) BTMIN = 2.*BTAV2/FLOAT(II) WRITE (LIS2, FMT='(/ '' SUBROUTINE BIJVOX'')') WRITE (LIS2, FMT='('' Bijvoet calculations'' / )') WRITE (LIS2, FMT='('' Values of abs(dFo) if >'', * '' abs(dFc) + 3 sig(dFo) are cut off to this value '' )') WRITE (LIS2, FMT='('' Values of '', * ''BT=|dFc*dFo|/sig(dFo)**2 >'', F8.2, * '' are cut off to this value'')') BTMIN WRITE (LIS2, FMT='(/,'' Statistics of the first 25 '', * '' Bijvoet pairs (cut off values are marked +)'')') WRITE (LIS2, FMT='( '' H K L dFc dFo'', * '' sig(dFo) BT Bcumul '')') MFR = 0 MFR25 = 0 I25 = 0 SUMP = 0.0 SUMQ = 0.0 SUMR = 0.0 SUMP25 = 0.0 SUMQ25 = 0.0 SUMR25 = 0.0 DO 150 I=1,MPAIR MFR = MFR + 1 MFR25 = MFR25 + 1 DFC = PAIRS(3,I) DFO = PAIRS(4,I) SIG2 = PAIRS(5,I) SIG = SQRT(SIG2) IF (ABS(DFO) .GT. ABS(DFC) + 3.* SIG) THEN DFO = (ABS(DFC) + 3. * SIG) * DFO / ABS(DFO) ADFO = '+' ELSE ADFO = ' ' ENDIF BT = DFC * DFO / SIG2 IF (MFR.LE.25) THEN QQ = ABS(BTMIN/BT) IF(QQ .LT. 1.) THEN BT = BT * QQ ABTAV = '+' ELSE ABTAV = ' ' ENDIF ENDIF SUMP = SUMP + BT SUMQ = SUMQ + ABS(BT) SUMR = SUMR + DFC**2 / SIG2 SUMP25 = SUMP25 + BT SUMQ25 = SUMQ25 + ABS(BT) SUMR25 = SUMR25 + DFC**2 / SIG2 IF (MFR .LE. 25) THEN HCODEF = PAIRS(2,I) SQ = SQRT(PAIRS(6,I)) CALL HKLC1U (HCODEF, HKLT) CALL KERF2I (HKLT, IHKL, 3) BCUM = SUMP/SUMQ WRITE (LIS2, FMT='(1X, I4, 2I3, 3X, 3F9.4, A1, F8.4, * F10.4, A1, F8.2)') * (IHKL(J), J=1,3), SQ, DFC, DFO, ADFO, SIG, BT, ABTAV, BCUM ENDIF IF (MOD(MFR, 25) .NE. 0) GOTO 150 I25 = I25 + 1 B = SUMP/SUMQ SIGB = (1. - ABS(B)) * SQRT(SUMR)/SUMQ IF (SIGB .LT. 0.0001) SIGB = 0.0001 BS = 2. * B / SIGB ARGPA = 0.707107 * ABS(BS) PPA = ERFU(ARGPA) B25 = SUMP25/SUMQ25 SIGB25 = (1. - ABS(B25)) * SQRT(SUMR25)/SUMQ25 IF (SIGB25 .LT. 0.0001) SIGB25 = 0.0001 BS25 = 2. * B25 / SIGB25 MFR25 = 0 SUMP25 = 0.0 SUMQ25 = 0.0 SUMR25 = 0.0 IF (MFR .NE. 25) GOTO 120 WRITE (LIS2,FMT='(/,'' Statistics in batches of 25 pairs'',/, * '' ------cumulative------------'', * '' ---individual-batches---'')') WRITE (LIS2,FMT='('' pairs'', 5X,''B sig(B) 2B/sig(B)'', * '' Prob B sig(B) 2B/sig(B)'')') 120 IF (BS .GT. 999.9) BS = 999.99 IF (BS25 .GT. 999.9) BS25 = 999.99 IF (BS .LT. -999.9) BS = -999.99 IF (BS25 .LT. -999.9) BS25 = -999.99 WRITE (LIS2, FMT=' (I5, F8.3, F7.3, F9.2, F6.3, 3X, * F8.3, F7.3, F9.2)') * MFR, B, SIGB, BS, PPA, B25, SIGB25, BS25 IF (MFR .NE. 100) GOTO 150 MSEL = 100 BSEL = B SIGSEL = SIGB PSEL = PPA 150 CONTINUE WRITE (LIS2, FMT='(/'' A better choice of batches: '')') WRITE (LIS1, FMT='(/'' Calculation of the BIJVOET'', * '' coefficients (B) and their probabilities (Prob)'')') DO 200 I = 1, 5 IF (MODC(I) .GE. MPAIR) GOTO 202 200 CONTINUE I = 5 MPAIR = MODC(5) 202 MODC(I) = MPAIR IF (I .EQ. 1) GOTO 210 DO 204 K = 1, I-1 MODC(K) = NINT (FLOAT(MPAIR * MODA(K)) / FLOAT(MODB(I))) 204 MODC(I) = MODC(I) - MODC(K) 210 MODB(1) = MODC(1) IF (I .EQ. 1) GOTO 220 DO 214 K = 2, I 214 MODB(K) = MODB(K-1) + MODC(K) 220 NBAT = I SUMP = 0. SUMQ = 0. SUMR = 0. IPAIR = 0 WRITE (LIS1, 222) NBAT WRITE (LIS2, 222) NBAT 222 FORMAT (/ ' ----------cumulative-------------- --------', * I2, ' individual batches----' / * ' pairs B sig(B) 2B/sig(B) Prob ', * ' pairs B sig(B) 2B/sig(B) Prob ') DO 320 I = 1, NBAT BSUMP = 0. BSUMQ = 0. BSUMR = 0. KBAT = MODB(I) KBBAT = MODC(I) 310 IPAIR = IPAIR + 1 DFC = PAIRS(3,IPAIR) DFO = PAIRS(4,IPAIR) SIG2 = PAIRS(5,IPAIR) SIG = SQRT(SIG2) IF (ABS(DFO) .GT. ABS(DFC) + 3.* SIG) THEN DFO = (ABS(DFC) + 3. * SIG) * DFO / ABS(DFO) PAIRS(4,IPAIR) = DFO ENDIF BT = DFC * DFO / SIG2 IF (IPAIR .LE. 25) THEN QQ = ABS(BTMIN/BT) IF(QQ .LT. 1.) THEN BT = BT * QQ ENDIF ENDIF PAIRS(1,IPAIR) = BT BSUMP = BSUMP + PAIRS(1,IPAIR) BSUMQ = BSUMQ + ABS(PAIRS(1,IPAIR)) BSUMR = BSUMR + PAIRS(3,IPAIR)**2 / PAIRS(5,IPAIR) IF (IPAIR .LT. KBAT) GOTO 310 SUMP = SUMP + BSUMP SUMQ = SUMQ + BSUMQ SUMR = SUMR + BSUMR BBAT = SUMP / SUMQ SIGB = (1. - ABS(BBAT)) * SQRT (SUMR) / SUMQ SIGM = AMAX1(SIGB, 0.002 * ABS(BBAT)) BBSS = 2. * BBAT / SIGM IF (BBSS .GT. 999.99) BBSS = 999.99 IF (BBSS .LT.-999.99) BBSS =-999.99 IF (SIGB .LT. 0.0001) SIGB = 0.0001 ARGPA = 0.707107 * ABS(BBSS) PA = ERFU(ARGPA) BBBAT = BSUMP / BSUMQ BSIGB = (1. - ABS(BBBAT)) * SQRT (BSUMR) / BSUMQ BSIGM = AMAX1(BSIGB, 0.002 * ABS(BBBAT)) BBBSS = 2. * BBBAT / BSIGM IF (BBBSS .GT. 999.99) BBBSS = 999.99 IF (BBBSS .LT.-999.99) BBBSS =-999.99 IF (BSIGB .LT. 0.0001) BSIGB = 0.0001 ARGPA = 0.707107 * ABS(BBBSS) BPA = ERFU(ARGPA) WRITE (LIS1, 318) KBAT, BBAT, SIGB, BBSS, PA, * KBBAT, BBBAT, BSIGB, BBBSS, BPA WRITE (LIS2, 318) KBAT, BBAT, SIGB, BBSS, PA, * KBBAT, BBBAT, BSIGB, BBBSS, BPA 318 FORMAT ( 2(I5, F8.3, F7.3, F8.2, F7.3, 2X)) IF (I .LT. NBAT) GOTO 320 IF (MPAIR .GT. 100) GOTO 320 MSEL = MPAIR BSEL = BBAT SIGSEL = SIGB PSEL = PA 320 CONTINUE WRITE (LIS1, 321) MSEL, BSEL, SIGSEL, PSEL WRITE (LIS2, 321) MSEL, BSEL, SIGSEL, PSEL 321 FORMAT (/ ' The Bijvoet coefficient for the strongest', I4, * ' Bijvoet pairs is' / ' B = ' , F6.3,'(', F5.3,') ', * ' and its probability is ' , F6.3 /) IF (PSEL .GT. 0.999) THEN IF (BSEL .GT. 0.0) THEN WRITE (LIS1, 325) WRITE (LIS2, 325) 325 FORMAT (' The atomic parameters of the structure are in ', * 'agreement with its ' / ' absolute configuration.' / ) ELSE WRITE (LIS1, 326) WRITE (LIS2, 326) 326 FORMAT (' The atomic parameters of the structure have to be ', * 'inverted' / * ' to be in agreement with its absolute configuration.'/) ENDIF RETURN ENDIF IF (BSEL .GT. 0.0) THEN WRITE (LIS1, 327) WRITE (LIS2, 327) 327 FORMAT (' The atomic parameters of the structure are in ', * 'agreement with' / ' its absolute configuration,' / * ' but inspect the Bijvoet coefficients to judge the validity.'/) ELSE WRITE (LIS1, 328) WRITE (LIS2, 328) 328 FORMAT (' The atomic parameters of the structure have to be ', * 'inverted' / * ' to be in agreement with its absolute configuration,' / * ' but inspect the Bijvoet coefficients to judge the validity.'/) ENDIF IF (PSEL .LT. 0.95) THEN WRITE (LIS1, 425) WRITE (LIS2, 425) 425 FORMAT (' Be careful !' /) ENDIF RETURN END SUBROUTINE SHAT 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 (IRD, IFILE(5) ) EQUIVALENCE (IPR1, IFILE(6) ) EQUIVALENCE (LIS1, IFILE(7) ) EQUIVALENCE (IATOLD, IFILE(10)) PARAMETER (NSLOT = 10, MAXAT = 2513) COMMON / / DUMMY(1), * ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), DUMMY(1)) COMMON /ATNAMA/ ATNAME(MAXAT) CHARACTER * 6 ATNAME DIMENSION SHIFT (3) CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ) IF (KINQ .EQ. -1) CALL KERROR(' No ATOMS file found', 0,' SHAT') CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT) CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD') CALL ATOMPR (LIS1, 7, ATXYZ, ATNAME, IZAT, NAT) 120 WRITE (IPR1, FMT = '('' Enter the shift vector (tx ty tz)'')') CALL KETERM (3, -1, KEND) IF (KEND .LT. 0 ) GOTO 120 CALL KERNAB (FNUM, SHIFT, 3) WRITE (CHOUT, FMT = '('' Shift vector applied: '',3F8.4)') SHIFT CALL SHOUT2 REWIND IATOMS DO 200 J = 1,NAT DO 200 I = 1,3 200 ATXYZ(I,J) = ATXYZ(I,J) + SHIFT(I) WRITE (CHOUT, FMT = '(''REMARK Shift vector: '',3F8.2)') SHIFT CALL ATOMPR (LIS1, 7, ATXYZ, ATNAME, IZAT, NAT) CALL ATOMWR (IATOMS, ATXYZ, ATNAME, NAT) CALL FILCLO (IATOMS, 'KEEP') RETURN END SUBROUTINE EULER CALL EULERC RETURN END SUBROUTINE EULERC 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 (IATMOD, IFILE(1)) EQUIVALENCE (IATOMS, IFILE(2)) EQUIVALENCE (IATOLD, IFILE(10)) EQUIVALENCE (ICRYS, IFILE(3)) EQUIVALENCE (IPR1, IFILE(6)) EQUIVALENCE (LIS1, IFILE(7)) EQUIVALENCE (LIS2, IFILE(8)) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) PARAMETER (MAXAT = 993) COMMON / / DUMMY(1), ATXYZ(10, MAXAT), IZAT(MAXAT), NAT DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), DUMMY(1)) COMMON /ATNAMA/ ATNAME(2513) CHARACTER * 6 ATNAME DIMENSION RR(3,3) WRITE(IPR1, FMT = '('' Preliminary version'')') CALL RDCRYS (ICRYS) CALL FILINQ (IATMOD, 'ATMOD', 'FORMATTED', 'INPUT', KINQ) IF (KINQ .LT. 0) CALL KERROR ('No ATMOD file', 0, 'EULER') CALL ATOMIN (IATMOD, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT) CALL KERINB (LIT, 1) IF (LIT(2) .NE. 'CARTX' .AND. LIT(2) .NE. 'CART') * CALL KERROR ('No CART or CARTX on ATMOD header', 0, 'EULER') CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ) IF (KINQ .GE. 0) THEN CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD') ENDIF CALL ATOMPR (LIS1, 7, ATXYZ, ATNAME, IZAT, NAT) 260 WRITE (IPR1, FMT = '('' Please, supply three Eulerian angles'')') CALL KETERM ( 3, 0, KEND) IF (KEND .LT. 0) GOTO 260 AIN = FNUM(1) BIN = FNUM(2) CIN = FNUM(3) WRITE (LIS1, FMT = '('' Euler angles: '',3F7.2)') AIN, BIN, CIN CALL MATABC (AIN, BIN, CIN, RR) CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ) WRITE (CHOUT, FMT = '('' ABC = '', 3F7.2)') AIN, BIN, CIN CALL ATOMWA (IATOMS) DO 300 I = 1,NAT CALL MATXV3 (RR, ATXYZ(1,I), ATXYZ(5,I)) CALL MAT6XV (CART2F, ATXYZ(5,I), ATXYZ(8,I)) WRITE (LIS2, FMT = '(3X, A6, 2X,3F8.4, F5.0,2(2X,3F8.4))') * ATNAME(I), (ATXYZ(J,I), J=1,10) WRITE (LIS1, FMT = '(3X, A6, 2X,3F8.4)') * ATNAME(I), (ATXYZ(J,I), J=8,10) WRITE (IATOMS, FMT = '(''ATOM'', 3X, A6, 2X,3F8.4)') * ATNAME(I), (ATXYZ(J,I), J=8,10) 300 CONTINUE WRITE(IATOMS, FMT = '(''END'')') CALL FILCLO (IATOMS, 'KEEP') CALL FILCLO (IATMOD, 'KEEP') RETURN END SUBROUTINE MATABC (AE, BE, CE, R) DIMENSION R(3,3) D2R = ATAN(1.0) / 45.0 CA = COS (AE * D2R) CB = COS (BE * D2R) CC = COS (CE * D2R) SA = SIN (AE * D2R) SB = SIN (BE * D2R) SC = SIN (CE * D2R) CALL MATEUL (CA, CB, CC, SA, SB, SC, R) RETURN END SUBROUTINE MATEUL (CA, CB, CC, SA, SB, SC, R) DIMENSION R(3,3) R(1,1) = CB R(1,2) = SB * SC R(1,3) = -SB * CC R(2,1) = SA * SB R(2,2) = CA * CC - SA * CB * SC R(2,3) = SA * CB * CC + CA * SC R(3,1) = CA * SB R(3,2) =-CA * CB * SC - SA * CC R(3,3) = CA * CB * CC - SA * SC RETURN END SUBROUTINE INVERT 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 SWHAND EQUIVALENCE (SWHAND, SWITCH(28)) 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)), (ICRYS, IFILE(3)) EQUIVALENCE (IRD, IFILE(5)), (IPR1, IFILE(6)), (LIS1, IFILE(7)) EQUIVALENCE (IATOLD, IFILE(10)) CHARACTER * 6 LL 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 PARAMETER (NSLOT = 10, MAXAT = 2513) COMMON / / DUMMY(1), * ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), DUMMY(1)) COMMON /ATNAMA/ ATNAME(MAXAT) CHARACTER * 6 ATNAME DIMENSION ZZ(3), AA(3), BB(3), CC(3) CALL RDCRYS (ICRYS) CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'INPUT', KINQ) IF (KINQ.EQ.-1) CALL KERROR ('ATOMS file not found',0,'INVERT') CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD') CALL ATOMIN (IATOMS, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT) REWIND IATOMS CALL KERNZA (0.0, ZZ, 3) DO 150 I = 1,NAT DO 150 J = 1,3 150 ZZ(J) = ZZ(J) + ATXYZ(J,I) DO 160 J =1,3 ZZ(J) = ZZ(J) / FLOAT(NAT) BB(J) = 1.0 IF (ZZ(J) .LT. 0.2) BB(J) = 0.5 IF (ZZ(J) .GT. 0.8) BB(J) = 1.5 CC(J) = ZZ(J) + 0.5 AA(J) = 1.0 IF (IPOLA .EQ. 7) AA(J) = CC(J) 160 CONTINUE GOTO (171, 171, 173, 171, 173, 173, 200, 200), IPOLA GOTO 191 171 I = IPOLA IF (I.EQ.4) I=3 AA(I) = CC(I) GOTO 192 173 I = 8 - IPOLA IF (I.EQ.5) I=1 AA(I) = CC(I) J = MOD (I, 3) + 1 AA(J) = CC(J) GOTO 193 191 IF (ISYST .GT. 3) GOTO 200 I = 1 AA(I) = BB(I) 192 IF (ISYST .GT. 3) GOTO 200 J = MOD (I, 3) + 1 AA(J) = BB(J) 193 IF (ISYST .GT. 3) GOTO 200 K = MOD (J, 3) + 1 AA(K) = BB(K) 200 DO 210 J = 1,3 210 ZZ(J) = AA(J) / 2. IF (SWHAND) THEN WRITE (CHOUT, FMT = '('' Inversion point: '', 3F9.5)') ZZ CALL SHOUT 220 WRITE(IPR1, 221) 221 FORMAT(' Do you wish to use another point? (Y,N,Q,H?)') CALL KETERM (0, 1, KEND) IF (KEND .LT. 0) GOTO 220 LL = LIT(1) IF (LL .EQ. 'Q') THEN WRITE(CHOUT,FMT='('' Terminal: Q=Quit: nothing done...'')') CALL SHOUT RETURN ENDIF IF (LL .EQ. 'N') THEN SWHAND = .FALSE. GOTO 240 ENDIF IF (LL .EQ. 'Y') GOTO 230 WRITE(IPR1, 227) 227 FORMAT (' Y: you will be prompted to supply another point,'/ * ' for instance 0 0 0 for x= -x, y= -y, z= -z,'/ * ' or 0.5 0.5 0.5 for x=1-x, y=1-y, z=1-z,'/ * ' but... there is no check for symmetry-errors !!!' / * ' Q: quit, stop, don.t do anything.'/ * ' N: use default (as printed above).') GOTO 220 ENDIF 230 WRITE (CHOUT, FMT = '('' Give coordinates of inversion point:'')') CALL SHOUT CALL KETERM (3, 0, KEND) IF (KEND .LT. 0) GOTO 230 DO 235 I = 1,3 ZZ(I) = FNUM(I) 235 AA(I) = ZZ(I) * 2.0 240 DO 250 I = 1,NAT DO 250 J = 1,3 250 ATXYZ(J,I) = AA(J) - ATXYZ(J,I) WRITE (IPR1, 260) NAT 260 FORMAT (' Number of atoms inverted', I5 ) WRITE (CHOUT, FMT = '('' Inversion point: '', 3F9.5)') ZZ CALL SHOUT WRITE (CHOUT, FMT = '('' Inversion point: '', 3F9.5)') ZZ CALL ATOMWR (IATOMS, ATXYZ, ATNAME, NAT) CALL FILCLO (IATOMS, 'KEEP') RETURN END SUBROUTINE BINPRI CALL BINPRX RETURN END SUBROUTINE BINPRX 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 (ICRYS, IFILE(3)) EQUIVALENCE (ICON, IFILE(4)) EQUIVALENCE (LIS1, IFILE(7)) 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 DIMENSION FITEMS(51), HKL(3) PARAMETER (MAXBUF = 198) DIMENSION BUFIN(MAXBUF) EQUIVALENCE (FITEMS(1),HCODE) EQUIVALENCE (FITEMS(1),HKL(1)) DIMENSION IBUFIN(MAXBUF), ITEMS(51), IHKL(3), THKL(3) PARAMETER (LCMAX = 2) CHARACTER*6 LCONDA (LCMAX) PARAMETER (LBMAX = 4) CHARACTER*6 LBIN (LBMAX) DIMENSION NBIN (LBMAX), NPRINT(LBMAX) DATA LBIN /'BINFO', 'BINFC', 'BINFC2', 'BINFFT' / DATA NBIN / 17, 27, 27, 29 / DATA NPRINT / 25, 25, 25, 25 / DATA LCONDA /'BINPRI', 'NPRINT' / CALL RDCRYS (ICRYS) 110 CALL RDCOND (ICON, LCONDA, LCMAX, KEND) GOTO (110, 112), KEND GOTO 114 112 IF (NFNUM.NE.4) CALL KERROR ('INCORR. NPRINT', 112, 'BINPRI') CALL KERF2I (FNUM, NPRINT, LBMAX) GOTO 110 114 DO 500 IFBIN = 11, 14 LB = IFBIN - 10 CALL FILINQ (IFBIN, LBIN(LB), 'UNFORMATTED', 'TEST', KINQ) IF (KINQ .EQ. -1) NPRINT(LB) = 0 IF (NPRINT(LB).LE.0) GOTO 500 CALL BINIFF (1, IFBIN, LBIN(LB), FITEMS, NIT, BUFIN, NEND) NB = NBIN(LB) CALL KERF2I (BUFIN, IBUFIN, NB) IF (IFBIN.GT.11) WRITE (LIS1, FMT='(''1BINPRI'')') WRITE (LIS1, 122) LBIN(LB), IFBIN, CHIN(1:6), CHIN(7:12), * CHIN(13:20), CHIN(21:80), (IBUFIN(K),K=1,4), NIT 122 FORMAT (//' Binary file ' , A6, ' is present at unit ',I2/ * ' file name ' , A6, ' for compound ',A6/ * ' generated by program ',A8/ * ' TITLE = ', A60 / * ' ITIME = ', I4, 2I3, I6 / * ' Number of items per reflection is ',I3 / * ' Specific data are'/) GOTO (1,2,3,4), LB 1 WRITE (LIS1, 301) IBUFIN(5), BUFIN(6), (IBUFIN(K), K=7,15) 301 FORMAT ( ' IRUN/FRIE STLMAX HKLMAX', * ' HMAX ', * ' HMIN '/ 6X, I4, F10.6, 3(5X, 3I4) /) WRITE (LIS1, 305) NPRINT(LB) 305 FORMAT ( ' Print' , I6, ' reflection records '/ * ' HCODE ( H K L ) Fobs sig ' /) GOTO 130 2 WRITE (LIS1, 302) IBUFIN(5), BUFIN(6), (IBUFIN(K), K=7,15), * (BUFIN(K),K=16,17),(BUFIN(K), K=18,20) 302 FORMAT ( ' IRUN/FRIE STLMAX HKLMAX ', * ' HMAX ', * ' HMIN ',/ 6X, I4, F10.6, 3(5X, 3I4) / * / ' SC Wils.P. BOV Wils.P. ', * 'SC 2dim.r. BP BR'/ 5(2X, F10.4)) WRITE (LIS1, 303) BUFIN(21), (IBUFIN(K), K=22,24), * IBUFIN(25), BUFIN(26), BUFIN(27) 303 FORMAT ( / ' STLMAX HKLMAX NAT', * ' P1SQ PSQ '/ * F10.4, 2X, 3I4, 6X, I4, 2F10.4/) WRITE (LIS1, 306) NPRINT(LB) 306 FORMAT ( ' Print' , I6, ' reflection records (hkl as in BINFO)'/ * ' Fcalc phase '/) GOTO 130 3 WRITE (LIS1, 302) IBUFIN(5), BUFIN(6), (IBUFIN(K), K=7,15), * (BUFIN(K), K=16,17), (BUFIN(K),K=18,20) WRITE (LIS1, 303) BUFIN(21), (IBUFIN(K), K=22,24), * IBUFIN(25), BUFIN(26), BUFIN(27) WRITE (LIS1, 307) NPRINT(LB) 307 FORMAT ( ' Print' , I6, ' reflection records (hkl as in BINFO)'/ * ' EPSIL2 SF2 SF2P FCALC phase FCALC phase '/) GOTO 130 4 WRITE (LIS1, 302) IBUFIN(5), BUFIN(6), (IBUFIN(K), K=7,15), * (BUFIN(K),K=16,17), (BUFIN(K), K=18,20) WRITE (LIS1, 304) BUFIN(21), (IBUFIN(K), K=22,24), * IBUFIN(25), (BUFIN(K),K=26,27), (IBUFIN(K), K=28,29) 304 FORMAT ( / ' STLMAX HKLMAX NAT', * ' P1SQ PSQ KEYFFT KFOUR'/, * F10.4, 2X, 3I4, 6X, I4, 2F10.4, 2(6X, I4)/) WRITE (LIS1, 308) NPRINT(LB) 308 FORMAT ( ' Print' , I6, ' reflection records '/ * ' H K L amplitude phase'/) GOTO 130 130 NREF = 0 IF (IFSTAT(IFBIN).NE.0) GOTO 500 140 CALL BINIFF (0, IFBIN, LBIN(LB), FITEMS, NIT, BUFIN, NEND) IF (NEND.LT.0) GOTO 490 NREF = NREF + 1 IF (NREF.GT.NPRINT(LB)) GOTO 140 CALL KERF2I (FITEMS, ITEMS, NIT) GOTO (11, 12, 13, 14), LB 11 CALL HKLC1U (HCODE, THKL) CALL KERF2I (THKL, IHKL, 3) WRITE (LIS1, 411) ITEMS(1), IHKL, (FITEMS(K), K=2,3) 411 FORMAT (I10, 2X,3I4, F10.3, F7.3) GOTO 140 12 WRITE (LIS1, 412) (FITEMS(K), K=1,2) 412 FORMAT (F10.3, F5.0) GOTO 140 13 WRITE (LIS1, 413) (FITEMS(K), K=1,NIT) 413 FORMAT (F6.0, 2F8.0, 4(F9.3, F5.0), 6(/16X, 4(F9.3, F5.0) )) GOTO 140 14 CALL KERF2I (HKL, IHKL, 3) WRITE (LIS1, 414) IHKL, (FITEMS(K), K=4,5) 414 FORMAT (' ', 3I4, F11.4, F6.1 ) GOTO 140 490 WRITE (LIS1, 492) NREF 492 FORMAT (' number of reflections ', I5) IF (LB.EQ.3) WRITE (LIS1, 494) 494 FORMAT (' (only independent reflections counted)' ) 500 CONTINUE RETURN END SUBROUTINE METFOU CALL KERROR('METFOUR not available ', 0, 'NUTS') END SUBROUTINE SELECT 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 (IRD, IFILE(5)), (IPR1, IFILE( 6)) EQUIVALENCE (LIS1, IFILE(7)), (LIS2, IFILE( 8)) EQUIVALENCE (IATOMS, IFILE(2)), (IDDS, IFILE(1)) EQUIVALENCE (ICON, IFILE(4)), (IATOLD, IFILE(10)) PARAMETER (NSLOT = 10, MAXAT = 2513) COMMON / / DUMMY(1), * ATXYZ(NSLOT,MAXAT), IZAT(MAXAT), ITAT(MAXAT), NAT DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), DUMMY(1)) COMMON /ATNAMA/ ATNAME(MAXAT) CHARACTER * 6 ATNAME CHARACTER * 80 CHINR LOGICAL SWRUN SWRUN = .FALSE. JRUN = -1 CALL COPY80 (IATOMS, 'ATOMS', IATOLD, 'ATOLD') CALL FILINQ (IATOLD, 'ATOLD', 'FORMATTED', 'INPUT ', KINQ) CALL FILINQ (IATOMS, 'ATOMS', 'FORMATTED', 'OUTPUT', KINQ) 105 WRITE (IPR1, * FMT = '('' Gives a run number '')') CALL KETERM (1, 0, KEND) IF (KEND .LT. 0) GOTO 105 JRUN = NINT(FNUM(1)) 110 CALL KERINA (IATOLD, LIT, 1, LEND) IF (LEND .EQ. -1) GOTO 300 IF (SWRUN) GOTO 120 IF (LIT(1) .EQ. 'Next' .OR. LIT(1) .EQ. 'NEXT') THEN IRUN = NINT(FNUM(4)) IF (IRUN .GT. JRUN) THEN WRITE(IPR1, FMT = '('' No success '')') RETURN ENDIF IF (JRUN .NE. IRUN) GOTO 110 SWRUN = .TRUE. WRITE (CHOUT, FMT = '(2X, A70)') CHIN(1:70) CALL SHOUT ENDIF GOTO 110 120 IF (LIT(1) .EQ. 'ATOMS' .OR. LIT(1) .EQ. 'ATMOD') GOTO 125 GOTO 110 125 CCODE = LIT(2) WRITE (CHOUT, FMT = '(2X, A70)') CHIN(1:70) CALL SHOUT READ (IATOLD, FMT = '(A80)') CHINR IF (CHINR(1:6) .EQ. 'REMARK') THEN WRITE (CHOUT, FMT = '(2X,A70)') CHINR(1:70) CALL SHOUT ELSE BACKSPACE IATOLD CHINR = ' ' ENDIF 130 WRITE (IPR1, * FMT = '(/, '' Do you want this atom set ?(Y/N,Q)'')') CALL KETERM (0, 1, KEND) IF (KEND .LT. 0) GOTO 130 IF (LIT(1) .EQ. 'N') THEN SWRUN = .FALSE. GOTO 110 ENDIF IF (LIT(1) .EQ. 'Q') RETURN IF (LIT(1) .NE. 'Y') GOTO 130 NAT = 1 BACKSPACE IATOLD READ (IATOLD, FMT = '(A80)') CHIN LEND = 999 150 CALL ATOMIA (IATOLD, ATXYZ, ATNAME, IZAT, MAXAT, NAT, LEND) IF (LEND . EQ .0) THEN NAT = NAT + 1 GOTO 150 ENDIF NAT = NAT - 1 CHOUT = ' ' IF (CHINR(1:6) .EQ. 'REMARK') CHOUT(1:72) = CHINR(8:80) CALL ATOMWR (IATOMS, ATXYZ, ATNAME, NAT) CALL FILCLO(IATOMS, 'KEEP') CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ) WRITE (IPR1, FMT = 211) 211 FORMAT(' Do you want to continue with program: TRACOR, PHASEX, ... * ....') 212 WRITE (IPR1, FMT = 213) 213 FORMAT(' Type a program name or Q for stop') CALL KETERM (0, 1, KEND) IF (KEND .LT. 0) GOTO 212 IF (LIT(1) .EQ. 'Q') THEN WRITE(IDDS, FMT = '(''STOP'')') REWIND IDDS CALL FILCLO (IDDS, 'KEEP') ELSE WRITE(IDDS, FMT = '(''STOP'')') REWIND IDDS CALL FILCLO(IDDS, 'KEEP') CALL FILINQ (ICON, 'CONDA', 'FORMATTED', 'TEST', KINQ) IF (KINQ .EQ. 0) CALL FILCLO (ICON, 'DELETE') ENDIF GOTO 400 300 WRITE (CHOUT, FMT = '('' End of the ATOLD file '')') 400 CALL FILCLO(IATOLD, 'KEEP') RETURN END SUBROUTINE KEPROR 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)) CHARACTER * 2 IISO DATA IISO / '==' / CALL KETIME (LIS2) WRITE (LIS2, 110) TITLE, PROGNM, (IISO, I=1,23) 110 FORMAT (' TITLE: ', A64 / ' End of program ' , A8 / + ' ' , 23A2 // '$FINISH') WRITE (LIS1, FMT='('' End of program '', A8 // ''$FINISH'')') * PROGNM RETURN END SUBROUTINE WRLIS2 COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH EQUIVALENCE (LIS2, IFILE(8)) COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 COMMON / / COMBLA(1), CHINT(420) CHARACTER CHINT *80 DIMENSION BLACOM(42000) EQUIVALENCE (COMBLA(1), BLACOM(1)) CHARACTER T *8 I = 1 WRITE (LIS2, FMT='(/ ''$FINISH'')') REWIND LIS2 111 READ (LIS2, FMT = '(A80)', END = 119) CHIN IF (CHIN(1:8) .EQ. '$FINISH ') GOTO 121 IF (CHIN(1:4) .NE. ' $TE') GOTO 111 CHINT(I) = CHIN I = I + 1 IF (I .EQ. 420) GOTO 121 GOTO 111 119 CALL KERROR (' kan niet', 119, 'MAIN') 121 BACKSPACE LIS2 CHINT(I) = ' ' WRITE (LIS2, FMT = '(/'' $TEMP summary'')') N = I I1 = 1 200 T = ' ' DO 225 I = I1, N IF (CHINT(I)(1:4) .EQ. ' $TE') THEN T = CHINT(I) (3:10) WRITE (LIS2, FMT = '(/'' $ '')') I2 = I GOTO 300 ENDIF 225 CONTINUE GOTO 900 300 DO 325 I = I2, N IF (CHINT(I)(3:10) .EQ. T) THEN WRITE (LIS2, FMT = '(A80)') CHINT(I) CHINT(I)(1:4) = ' ' ENDIF 325 CONTINUE I1 = I2 GOTO 200 900 WRITE (LIS2, FMT = '(/'' $ ------- '')') RETURN END