CSUBNIJX2 === file NIJX2.F = Part 2 of the NIJX subr. Updt: 4 Nov. 99 * Note: NIJX = NIJX1 + NIJX2 NIJX2 is computer independent. * Note: for NIJX1 various versions are supplied: IBM, VAX/VMS, unix etc. *----------------------------------------------------------------------- **** Comments NIJX1 + NIJX2 * WARNING : COMMON / / too small for TRAVEC **** modifications NIJX1 + NIJX2 / log / **** last on top * 04 Nov KEPROX for DDOKA set KEYS(20)=+17 (corr!) SUBROUTINE KEDATE 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)) CHARACTER * 4 M(12) DIMENSION L(12) DATA M / 'Jan.', 'Feb.', 'Mar.', 'Apr.', 'May ', 'June', + 'July', 'Aug.', 'Sep.', 'Oct.', 'Nov.', 'Dec.'/ DATA L / 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 / DATA IPR /0/ IF (IPR .NE. 0) IPR = LIS1 IF (IPR .EQ. 0) IPR = LIS2 CALL DATIME (I1, I2, I3) CALL KERNZI (0, ITIME, 3) IF (I3.GT.0) GOTO 110 WRITE (LIS2, 100) 100 FORMAT (' TIME REPORT NOT AVAILABLE') RETURN 110 ITIME(1) = I3 / 1000 + 1900 IF (MOD(ITIME(1),4).EQ.0) L(2) = 29 IL = MOD(I3,1000) DO 120 I=1,12 IF (IL.LE.L(I)) GOTO 130 120 IL = IL - L(I) I = 12 130 ITIME(2) = I ITIME(3) = IL IHH = I1 / 100 IMM = I1 - 100 * IHH WRITE (IPR, 140) I3, IHH, IMM, IL, M(I), ITIME(1) 140 FORMAT (/7X, ' Day number:' ,I6, '. The time:', I3, ' h', I3, * ' min.', ' The date:', I3, ' ', A4, I5) RETURN END SUBROUTINE KETIME (IPRX) 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 *4 MONTH(12) DATA MONTH / 'Jan.', 'Feb.', 'Mar.', 'Apr.', 'May ', 'June', * 'July', 'Aug.', 'Sep.', 'Oct.', 'Nov.', 'Dec.'/ DATA ISW / 0 / DATA IREL / 0 / CALL DATIME (I1, I2, I3) IF (I3.LE.0) RETURN IF (ISW.NE.0) GOTO 100 ISW = 1 IREL = I2 100 ITIME(4) = I2 - IREL IF (ITIME(4).EQ.0 .OR. IPRX.LE.0) RETURN F = FLOAT(ITIME(4)) / 1000. M = ITIME(2) WRITE (IPRX, 110) ITIME(3), MONTH(M), ITIME(1), PROGNM, F 110 FORMAT (/' Time report. Date: ', I3, 1X, A4, I5, * 4X, 'CPU time used by ', A8, ':', F7.3, ' s') RETURN END SUBROUTINE KERNAB (A, B, N) DIMENSION A(N), B(N) DO 100 I=1,N 100 B(I) = A(I) RETURN END SUBROUTINE KERNAI (IA, IB, N) DIMENSION IA(N), IB(N) DO 100 I=1,N 100 IB(I) = IA(I) RETURN END SUBROUTINE KERNZA (X, A, N) DIMENSION A(N) DO 100 I=1,N 100 A(I) = X RETURN END SUBROUTINE KERNZI (IX, IA, N) DIMENSION IA(N) DO 100 I=1,N 100 IA(I) = IX RETURN END SUBROUTINE KERNZ1 (CH, CHA, N) CHARACTER * 1 CH, CHA(N) DO 100 I=1,N 100 CHA(I) = CH RETURN END SUBROUTINE KERNZ6 (CH, CHA, N) CHARACTER * 6 CH, CHA(N) DO 100 I=1,N 100 CHA(I) = CH RETURN END SUBROUTINE KEREQ1 (L, LL, N, KEND) CHARACTER * 1 LL(N), L DO 100 KEND=1,N IF (LL(KEND).EQ.L) GOTO 110 100 CONTINUE KEND = -1 110 RETURN END SUBROUTINE KEREQ6 (L6, LL6, N, KEND) CHARACTER * 6 L6, LL6(N) DO 110 KEND=1,N IF (L6.NE.LL6(KEND)) GOTO 110 RETURN 110 CONTINUE KEND = -1 RETURN END SUBROUTINE KERC2I (L, KEND) CHARACTER * 1 L, LLL(49), LLC(26) DATA LLL / '1','2','3','4','5', '6','7','8','9',' ', + 'A','B','C','D','E', 'F','G','H','I','J', + 'K','L','M','N','O', 'P','Q','R','S','T', + 'U','V','W','X','Y', 'Z','+','-','.',',', + '*','/','=','$','''','(',')','?',':' / DATA LLC / 'a','b','c','d','e', 'f','g','h','i','j', + 'k','l','m','n','o', 'p','q','r','s','t', + 'u','v','w','x','y', 'z' / KEND = 0 IF (L.EQ.'0') RETURN CALL KEREQ1 (L, LLL, 49, KEND) IF (KEND.GT.0) RETURN CALL KEREQ1 (L, LLC, 26, KEND) IF (KEND.GT.0) KEND = KEND + 10 RETURN END SUBROUTINE KERI2C (I, CCC, N) CHARACTER * 6 CCC CHARACTER * 1 N10(10) DATA N10 / '1', '2', '3', '4', '5', '6', '7', '8', '9', '0' / CCC = ' ' JNUM = IABS(I) NN = N IF (NN .GT. 6) NN = 6 K = 10**NN IF (JNUM .GE. K) JNUM = K-1 J = K / 10 DO 100 L=1,NN IF (JNUM.GE.J) GOTO 110 NN = NN- 1 J = J / 10 100 CONTINUE 110 DO 120 L=1,NN K = JNUM / J IF (K.EQ.0) THEN CCC(L:L) = N10(10) ELSE CCC(L:L) = N10(K) ENDIF JNUM = JNUM - K*J 120 J = J / 10 RETURN END SUBROUTINE KERI2F (IA, FA, N) DIMENSION IA(N), FA(N) DO 100 I=1,N 100 FA(I) = IA(I) RETURN END SUBROUTINE KERF2I (FA, IA, N) DIMENSION FA(N), IA(N) DO 100 I=1,N 100 IA(I) = NINT (FA(I)) RETURN END SUBROUTINE KERC2U (CA, CB, N) CHARACTER CA *(*), CB *(*) CHARACTER * 1 LUC(26), LLC(26) DATA LUC / 'A','B','C','D','E', 'F','G','H','I','J', + 'K','L','M','N','O', 'P','Q','R','S','T', + 'U','V','W','X','Y', 'Z' / DATA LLC / 'a','b','c','d','e', 'f','g','h','i','j', + 'k','l','m','n','o', 'p','q','r','s','t', + 'u','v','w','x','y', 'z' / DO 120 I = 1, N CB(I:I) = CA(I:I) IF (CB(I:I) .EQ. ' ') GOTO 120 CALL KEREQ1 (CB(I:I), LLC, 26, KEND) IF (KEND .LE. 0) GOTO 120 CB(I:I) = LUC(KEND) 120 CONTINUE RETURN END SUBROUTINE KERICH (I, CH, KEND) CHARACTER * 1 CH, LLL(50), LLC(26) DATA LLL / '1','2','3','4','5', '6','7','8','9',' ', + 'A','B','C','D','E', 'F','G','H','I','J', + 'K','L','M','N','O', 'P','Q','R','S','T', + 'U','V','W','X','Y', 'Z','+','-','.',',', + '*','/','=','$','''','(',')','?',':','@' / DATA LLC / 'a','b','c','d','e', 'f','g','h','i','j', + 'k','l','m','n','o', 'p','q','r','s','t', + 'u','v','w','x','y', 'z' / IF (I .GT. 99) GOTO 100 IF (I .EQ. 0) THEN CH = '0' ELSEIF (I .LT. 0 .OR. I .GT. 76) THEN CH = ' ' ELSEIF (I .LE. 50) THEN CH = LLL(I) ELSE CH = LLC (I - 50) ENDIF RETURN 100 CONTINUE KEND = 0 IF (CH .EQ. '0') RETURN CALL KEREQ1 (CH, LLL, 50, KEND) IF (KEND.GT.0) RETURN CALL KEREQ1 (CH, LLC, 26, KEND) IF (KEND.GT.0) KEND = KEND + 50 IF (KEND.LE.0) KEND = 97 RETURN END SUBROUTINE KEPROG (NAME) CHARACTER NAME *(*) 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 NIJMEG EQUIVALENCE (NIJMEG, SWITCH(1)) 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)), (IDDJ, IFILE(1)), (IDDS, IFILE(2)) EQUIVALENCE (IRD, IFILE(5)), (IHELP, IFILE(3)) EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (ISTOP, IFILE(20)) EQUIVALENCE (IS, KEYS(17)), (IT, KEYS(18)), (IN, KEYS(19)) PARAMETER (NCHMAX=517) COMMON / / DUMMY(1), CHONDA(NCHMAX) CHARACTER * 80 CHONDA, CHINJ DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), DUMMY(1)) LOGICAL FIRST CHARACTER * 2 ISTAR DATA ISTAR / '**' / DATA FIRST /.TRUE./ DO 100 I=1,20 IFSTAT(I) = -2 100 IFILE(I) = I CHOUT = ' ' PROGNM = NAME PROSNM = ' ' IF (FIRST) THEN TITLE = ' ' CCODE = 'CCODE' CALL KERNZI (0, ITIME, 4) ENDIF CALL KERNZI (0, KEYS, 28) DO 101 I=1,28 101 SWITCH(I) = .FALSE. SWITCH(9) = FIRST CALL FILINQ (IDDJ, 'DDJOB', 'FORMATTED', 'INPUT', KIDDJ) KEYS(4) = KIDDJ IF (KIDDJ .NE. 0) GOTO 102 CALL KERINA (IDDJ, LIT, 1, LEND) CHINJ = CHIN CALL FILCLO (IDDJ, 'KEEP') CCODE = LIT(1) 102 CALL RDDCON CALL KEYSWI CALL FILINQ (ISTOP, 'DDSTOP', 'FORMATTED', 'INPUT', KINQ) CALL FILCLO (ISTOP, 'DELETE') KEYS(22) = 2 CALL FILINQ (LIS1, 'LIS1', 'FORMATTED', 'OUTPUT', KINQ) CALL FILINQ (LIS2, 'LIS2', 'FORMATTED', 'OUTPUT', KINX) IF (CCODE.EQ.'END' .OR. CCODE.EQ.'HELP' .OR. CCODE.EQ.'H' .OR. * CCODE.EQ.'CCODE' .OR. CCODE.EQ.'?' .OR. CCODE.EQ.'BATCH') RETURN ILIS2 = 0 IF (KINX .LT. 0) GOTO 110 105 READ( LIS2, FMT = '(A80)', END = 106) CHIN IF (CHIN(1:7) .EQ. '$FINISH' ) GOTO 107 ILIS2 = 1 GOTO 105 106 IF (ILIS2 .EQ. 0) GOTO 110 ILIS2 = -1 107 BACKSPACE LIS2 110 I = 0 IF (KINQ .LT. 0) GOTO 120 111 READ( LIS1, FMT = '(A80)', END = 113) CHIN IF (CHIN(1:7) .EQ. '$FINISH' ) GOTO 125 I = 1 GOTO 111 113 IF (I .EQ. 0) GOTO 120 BACKSPACE LIS1 WRITE (LIS1, 115) WRITE (IPR1, 115) 115 FORMAT (// ' Problems ! ... File LIS1 is incorrectly closed'/) WRITE (IPR1, FMT='('' See LIS1 ...''/)') CALL FILCLO (IHELP, 'KEEP') CALL XHELP (IHELP, LIS1, 10.0) WRITE (IPR1, 116) PROGNM 116 FORMAT (/'NOTE: this interrupt-ERROR did not happen in program ', * A8 / ' but in the preceding program (see above).') PROGNM = ' ' CALL KESTOP CALL KEPROX 120 KEYS(22) = 1 WRITE (LIS1, 122) (ISTAR, I=1,70) 122 FORMAT (/// 1X, 35A2, '*' / ' ****', 62X, ' ****' / ' ****', +' The DIRDIF program system, version 99.2, update 4 Nov. 1999 ' + ,'****' / ' ****', 62X, ' ****' / 1X, 35A2, '*') IS = 992 IT = 806 CALL FILCLO (IHELP, 'KEEP') CALL XHELP (IHELP, LIS1, 11.0) CALL FILCLO (IHELP, 'KEEP') GOTO 130 125 BACKSPACE LIS1 130 CONTINUE IF (KINX .LT. 0) GOTO 140 IF (ILIS2 .GE. 0) GOTO 150 135 FORMAT (// ' Problems ! ... File LIS2 is incorrectly closed'/) WRITE (LIS1, 135) WRITE (IPR1, 135) WRITE (IPR1, FMT='('' See LIS1 ...''/)') CALL FILCLO (IHELP, 'KEEP') CALL XHELP (IHELP, LIS1, 10.0) WRITE (IPR1, 116) PROGNM PROGNM = ' ' CALL KESTOP CALL KEPROX 140 WRITE (LIS2, FMT='(''1 File LIS2: Auxiliary listing''/ * '' !! Extra information for troublesome structures !!''/ * '' Do not print ... Compare with LIS1 = LISTING print''/)') WRITE (LIS2, 122) (ISTAR, I=1,70) 150 WRITE (LIS2, 152) (ISTAR, I=1,23), PROGNM, (ISTAR, I=1,23) 152 FORMAT (/ 1X, 23A2 / ' ****', 38X, '****' / ' ****', 16X, A8, + 14X, '****' / ' ****', 38X, '****' / 1X, 23A2 ) CALL KEDATE IF (KINQ .LT. 0) THEN CALL KEDATE CALL KETIME (LIS1) ELSE CALL KETIME (0) ENDIF IF (CCODE.EQ.'ATMOD' .OR. CCODE.EQ.'ORBASE') GOTO 911 WRITE (CHOUT, FMT='(''0============ Program '', A8)') PROGNM IF (PROGNM .EQ. 'DDSTART') THEN IN = IS IF (IN .GT. 900) IN = IN - 900 IN = IN * 10000 + IT ENDIF CALL LOGRD (IDDL, 'DDLOG', I) IF (I .GT. 0) THEN IF (LIT(1) .NE. 'DDLOG') THEN REWIND IDDL CALL KERINA (IDDL, LIT, 1, I) ENDIF IF (CCODE .EQ. 'CCODE') CCODE = LIT(2) IF (CCODE .NE. LIT(2)) THEN CHOUT = ' Wrong CCODE on DDLOG file: typing error? ' CALL SHOUT CHOUT = ' Wrong directory? Wrong compound code? ' CALL SHOUT CALL KERROR (' What happened ??? ', 152, 'KEPROG') ENDIF IF (CCODE .NE. 'NONAME') THEN IF (CCODE(5:6) .EQ. ' ') THEN CCODE = ' ' CCODE(3:6) = LIT(2)(1:4) ELSEIF (CCODE(6:6) .EQ. ' ') THEN CCODE = ' ' CCODE(2:6) = LIT(2)(1:5) ENDIF WRITE (CHOUT, FMT='(''0============ Execute program '', A8, * '' ============ for compound: '', A6 )') PROGNM, CCODE CCODE = LIT(2) ENDIF ENDIF CALL SHOUT CALL LOGRD (IDDL, 'RUN', IRUN) IF (IRUN .LE. 0) THEN IRUN = 0 ELSE IRUN = NINT(FNUM(2)) CALL LOGRD (IDDL, 'TITLE', ITIT) IF (ITIT .EQ. 1) THEN TITLE = CHIN(7:70) WRITE (LIS1, 160) TITLE WRITE (LIS2, 160) TITLE 160 FORMAT (' LOG TITLE: ', A64) ENDIF ENDIF KEYS(13) = IRUN CALL FILCLO (IDDL, 'KEEP') IF (.NOT. FIRST) GOTO 211 KEYS(5) = -1 CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'INPUT', KIDDS) IF (KIDDS .EQ. -1) GOTO 211 CALL KERINA (IDDS, LIT(32), 1, LEND) IF (LIT(1) .NE. PROGNM(1:6)) THEN CHOUT = ' Warning: unexpected (incorrect?) DDSYST file' CALL SHOUT KEYS(5) = 1 GOTO 211 ENDIF KEYS(5) = 0 NCH = 0 201 CALL KERINA (IDDS, LIT(32), 1, LEND) IF (LEND .EQ. -1) GOTO 207 NCH = NCH + 1 CHONDA(NCH) = CHIN GOTO 201 207 REWIND IDDS DO 208 I = 1, NCH 208 WRITE (IDDS, FMT = '(A80) ') CHONDA(I) REWIND IDDS CALL FILCLO (IDDS, 'KEEP') 211 FIRST = .FALSE. IF (KIDDJ .NE. 0) RETURN 911 CHIN = CHINJ CALL KERINB (LIT(32), 1) IF (LIT(2) .EQ. 'BATCH') SWITCH(8) = .TRUE. IF (CCODE .NE. ' ') THEN CCODE = LIT(1) WRITE (CHOUT, FMT='(''0'', 64(''=''), 1X, A6)') CCODE CALL SHOUT ENDIF RETURN END SUBROUTINE KEPROX 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 (IDDOKA, KEYS(10)) CHARACTER * 2 IISO DATA IISO / '==' / CALL KEYSWI CALL KETIME (LIS2) IF (TITLE .NE. ' ') WRITE (LIS2, 110) TITLE 110 FORMAT (' TITLE: ', A64) WRITE (LIS2, 111) PROGNM, (IISO, I=1,23) 111 FORMAT (' End of program ' , A8 / + ' ' , 23A2 // '$FINISH') WRITE (LIS1, FMT='('' End of program '', A8 // ''$FINISH'')') * PROGNM IF (IDDOKA .EQ. -17) THEN IDDOKA = 17 DO 200 I=1,20 IF (I.GE.6 .AND. I.LE.8) GOTO 200 CALL FILCLO (I, 'KEEP') 200 CONTINUE RETURN ENDIF STOP 0 END SUBROUTINE KERNER (KEY, NAME) CHARACTER NAME *(*), NAMEX *8 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 (IDDS, IFILE(2)), (ICON, IFILE(4)) EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)), (LIS2, IFILE(8)) EQUIVALENCE (ISTOP, IFILE(20)) EQUIVALENCE (IRUN, KEYS(13)) CHARACTER * 6 SUBPGM DATA SUBPGM /'SUBPGM'/ NAMEX = NAME IF (PROSNM.EQ.' ') SUBPGM=' ' CLOSE (UNIT = ISTOP) CALL FILINQ (ISTOP, 'DDSTOP', 'FORMATTED', 'OUTPUT', KINQ) IF (KINQ .LT. 0) THEN WRITE (ISTOP, FMT= '(''DDSTOP error stop in RUN'', * I4, '' for CCODE = '', A6)') IRUN, CCODE WRITE (ISTOP, FMT= '(''ERROR MESSAGE:'')') ELSE READ (ISTOP, FMT='(1X)') READ (ISTOP, FMT='(1X)') READ (ISTOP, FMT='(1X)') ENDIF WRITE (CHOUT, 100) PROGNM, SUBPGM, PROSNM, NAMEX 100 FORMAT (' ERROR STOP IN ' ,A8, 3X,A6,1X,A6,' MODULE ',A8) WRITE (LIS2, 100) PROGNM, SUBPGM, PROSNM, NAMEX WRITE (ISTOP,100) PROGNM, SUBPGM, PROSNM, NAMEX CALL SHOUT IF (KEY.EQ.0) GOTO 190 IF (KEY.LT.0) GOTO 120 WRITE (CHOUT, 110) KEY WRITE (ISTOP, 110) KEY 110 FORMAT (' ERROR (unexpected) OCCURED NEAR LABEL NUMBER', I6) CALL SHOUT GOTO 190 120 WRITE (CHOUT, 130) KEY WRITE (ISTOP, 130) KEY 130 FORMAT (' ERROR NUMBER', I5) CALL SHOUT IF (KEY.EQ.-1) WRITE (CHOUT, 140) IF (KEY.EQ.-1) WRITE (ISTOP, 140) 140 FORMAT (' ERROR : INPUT DATA INCORRECT') CALL SHOUT IF (KEY.EQ.-2) WRITE (CHOUT, 150) IF (KEY.EQ.-2) WRITE (ISTOP, 150) 150 FORMAT (' ERROR : INPUT DATA FILE(S) INCORRECT') CALL SHOUT IF (KEY.EQ.-3) WRITE (CHOUT, 160) IF (KEY.EQ.-3) WRITE (ISTOP, 160) 160 FORMAT (' ERROR : SORRY, DATA IS INCONSISTENT') CALL SHOUT IF (KEY.EQ.-4) WRITE (CHOUT, 170) IF (KEY.EQ.-4) WRITE (ISTOP, 170) 170 FORMAT (' ERROR ..MAY BE PROGRAMMERS ERROR..') CALL SHOUT IF (KEY.EQ.-5) WRITE (CHOUT, 180) IF (KEY.EQ.-5) WRITE (ISTOP, 180) 180 FORMAT (' ERROR ... SEE MANUAL FOR DETAILS....') IF (KEY.EQ.-6) THEN WRITE (CHOUT, 140) WRITE (ISTOP, 140) CALL SHOUT WRITE (CHOUT, FMT='('' ERROR : LAST INPUT RECORD WAS:'')') WRITE (ISTOP, FMT='('' ERROR : LAST INPUT RECORD WAS:'')') CALL SHOUT WRITE (IPR1, 181) CHIN(1:72) WRITE (LIS1, 181) CHIN(1:72) WRITE (LIS2, 181) CHIN(1:72) WRITE (ISTOP,181) CHIN(1:72) 181 FORMAT (' ERROR ! ', A72) ENDIF 190 CONTINUE WRITE (LIS1, 187) WRITE (ISTOP,187) 187 FORMAT (/' ERROR ! Here follows a general ERROR message.'/ * ' The present error-stop is the result of an internal test'/ * ' which could (may be) refer to a user-error. '/ * ' If you understand the printed message, ignore the following', * ' lines.'/ ' In most cases,', * ' error-stops occur at unexpected places or for unexpected'/ * ' reasons, and consequently the error messages are ', * 'not transparant'/ * ' for the user. At present (1999) we are trying to improve those' * / ' messages, but that is a slow process... ') WRITE (LIS1, 188) WRITE (ISTOP,188) 188 FORMAT ( * ' If the present error message is not clear to you, please, ', * 'tell us'/ * ' about it: we can help..., at least we can explain the message,' * / ' and we learn from your cooperation.'/ * ' We need to know what can go wrong.'/ * ' And hopefully next DIRDIF release can be improved.'/ * ' Thank you for your help. Paul T. Beurskens.'/) CALL KETIME (LIS1) CALL KETIME (LIS2) CALL KETIME (ISTOP) WRITE (ISTOP, FMT='(''STOP'')') IF (NAMEX .EQ. 'FILINQ') THEN CLOSE (UNIT = IDDS) OPEN (UNIT = IDDS) ELSE CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'TEST', KINQ) IF (KINQ .LT. 0) GOTO 220 ENDIF REWIND IDDS WRITE (IDDS, FMT='(''STOP'')') REWIND IDDS CALL FILCLO (IDDS, 'KEEP') IF (NAMEX .EQ. 'FILINQ') GOTO 230 220 CALL FILINQ (ICON, 'CONDA', 'FORMATTED', 'TEST', KINQ) IF (KINQ .EQ. 0) CALL FILCLO (ICON, 'DELETE') CALL KEYSWI 230 CONTINUE WRITE (LIS1, FMT='(/''$FINISH'')') WRITE (LIS2, FMT='(/''$FINISH'')') STOP 1 END SUBROUTINE KERROR (MESGE, KEY, NAME) CHARACTER MESGE *(*) , MESGEX *70 CHARACTER NAME *(*) , NAMEX *8 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 (ISTOP, IFILE(20)) EQUIVALENCE (IRUN, KEYS(13)) NAMEX = NAME MESGEX = MESGE WRITE (CHOUT, FMT='('' ERROR MESSAGE: '')') CALL SHOUT WRITE (IPR1, 100) MESGEX WRITE (LIS1, 100) MESGEX WRITE (LIS2, 100) MESGEX 100 FORMAT (' ERROR : ', A70) CLOSE (UNIT = ISTOP) CALL FILINQ (ISTOP, 'DDSTOP', 'FORMATTED', 'OUTPUT', KINQ) WRITE (ISTOP, FMT= '(''DDSTOP error stop in RUN'', * I4, '' for CCODE = '', A6)') IRUN, CCODE WRITE (ISTOP, FMT='(''ERROR MESSAGE:'')') WRITE (ISTOP, 100) MESGEX WRITE (ISTOP, FMT='(''END'')') CALL KERNER (KEY, NAME) END SUBROUTINE KESTOP 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 (IDDS, IFILE(2)), (ICON, IFILE(4)) CALL FILCLO (IDDS, 'KEEP') CALL FILINQ (IDDS, 'DDSYST', 'FORMATTED', 'OUTPUT', KINQ) WRITE (IDDS, FMT='(''STOP'')') REWIND IDDS CALL FILCLO (IDDS, 'KEEP') CALL FILCLO (ICON, 'KEEP') CALL FILINQ (ICON, 'CONDA', 'FORMATTED', 'TEST', KINQ) IF (KINQ .EQ. 0) CALL FILCLO (ICON, 'DELETE') CALL KEYSWI END SUBROUTINE KERINA (IRD, L, LMAX, LEND) CHARACTER * 6 L(LMAX) 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 LEND = 0 IF (IRD.LE.0 .OR. IRD.GT.20) CALL KERROR (' IRD?',-4,'KERINA') READ (IRD, 110, ERR = 120, END = 120, IOSTAT = IFSTAT(IRD)) CHIN 110 FORMAT (A80) IF (IFSTAT(IRD) .EQ. 0) GOTO 130 120 LEND = -1 CHIN = ' ' 130 CALL KERINB (L, LMAX) IF (LEND.LE.-1) RETURN IF (LIT(1).EQ.'END ') LEND = 4 IF (LIT(1).EQ.'FINISH') LEND = 5 IF (LIT(1).EQ.'STOP ') LEND = 6 RETURN END SUBROUTINE KERINB (LUSER, LUMAX) 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 LUSER(LUMAX) CHARACTER * 1 CH1 CHARACTER * 6 CHLIT, IBL, LBOS DATA IDMAX / 32 / DATA IBL /' '/ DATA MCOL / 72 / CALL KERNZ6 (IBL, LIT, IDMAX) CALL KERNZA (0.0, FNUM, IDMAX) CALL KERNZI (0, NCOLN, IDMAX) CALL KERNZI (0, NCOLL, IDMAX) CALL KERNZI (0, NFDOT, IDMAX) CALL KERNZI (0, NFDOL, IDMAX) CALL KERNZI (0, NLUSER, IDMAX) LUMA = LUMAX IF (LUMA.EQ.1 .AND. LUSER(1).EQ.' ') LUMA = 0 NFNUM = 0 NLIT = 0 ITEM = 0 KEND = 0 NEND = 0 I = 1 110 IF (I.GT.MCOL) GOTO 270 DO 120 K=I,MCOL CH1 = CHIN(K:K) IF (CH1.NE.' ' .AND. CH1.NE.',') GOTO 130 120 CONTINUE GOTO 270 130 NONUM = 0 NONUM2 = 0 NSIG = 0 NDOT = 0 I = K DO 170 K=I,MCOL CH1 = CHIN(K:K) CALL KERC2I (CH1, J) IF (J.GE.0 .AND. J.LE.9) GOTO 140 IF (CH1.EQ.'.') GOTO 150 IF (J.LT.0 .OR. J.GE.41) GOTO 240 IF (J.GE.11 .AND. J.LE.36) GOTO 240 IF (NDOT.EQ.1 .AND. NONUM.EQ.0) GOTO 240 IF (CH1.EQ.',' .AND. NONUM.EQ.0) GOTO 240 IF (CH1.EQ.',') GOTO 180 IF (CH1.EQ.'+'.OR. CH1.EQ.'-') GOTO 160 IF (NONUM2.EQ.1) GOTO 240 IF (NSIG.EQ.1) GOTO 170 IF (NONUM.EQ.0) GOTO 240 GOTO 180 140 NONUM = 1 NONUM2 = 0 NSIG = 0 GOTO 170 150 NDOT = NDOT + 1 IF (NDOT.EQ.2) GOTO 240 GOTO 170 160 IF (NSIG.EQ.1) GOTO 240 IF (NDOT.EQ.1 .AND. NONUM.EQ.0) GOTO 240 NSIG = 1 NONUM2 = NONUM NONUM = 0 NDOT = 0 170 CONTINUE IF (NONUM.EQ.0) GOTO 240 180 ITEM = ITEM + 1 NFNUM = NFNUM + 1 IF (NFNUM.LE.IDMAX) NCOLN(NFNUM) = I IF (NFNUM.GT.IDMAX) NCOLN(IDMAX) = - IABS(NCOLN(IDMAX)) NONUM = 0 NSIG = 0 NDOT = 0 DO 220 K=I,MCOL CH1 = CHIN(K:K) CALL KERC2I (CH1, J) IF (J.GE.0 .AND. J.LE.9) GOTO 190 IF (CH1.EQ.'.') GOTO 200 IF (CH1.EQ.',') GOTO 230 IF (CH1.EQ.'+' .OR. CH1.EQ.'-') GOTO 210 IF (J.NE.10) CALL KERNER (-4, 'KERINB') IF (NSIG.EQ.1) GOTO 220 IF (NONUM.EQ.1) GOTO 230 CALL KERNER (-4, 'KERINB') 190 CONTINUE NONUM = 1 NSIG = 0 GOTO 220 200 NDOT = 1 GOTO 220 210 IF (NONUM.EQ.1) GOTO 230 NSIG = 1 NONUM = 0 220 CONTINUE KEND = 999 230 CONTINUE CALL KERINF (CHIN, I, K-1, A, NEND) I = K IF (NFNUM.LE.IDMAX) FNUM(NFNUM) = A IF (NFNUM.LE.IDMAX) NFDOT(NFNUM) = NDOT+1 IF (NFNUM.GT.IDMAX) NFNUM = IDMAX IF (ITEM.LE.IDMAX) NFDOL(ITEM) = NDOT+1 GOTO 110 240 ITEM = ITEM + 1 NLIT = NLIT + 1 IF (NLIT.LE.IDMAX) NCOLL(NLIT) = I IF (NLIT.GT.IDMAX) NCOLL(IDMAX) = - IABS(NCOLL(IDMAX)) L = 1 CHLIT = ' ' DO 250 K=I,MCOL CH1 = CHIN(K:K) IF (CH1.EQ.' ' .OR. CH1.EQ.',') GOTO 260 IF (L.LE.6) CHLIT(L:L) = CH1 250 L = L + 1 KEND = 999 L = MCOL - I + 2 260 I = K IF (NLIT.LE.IDMAX) LIT(NLIT) = CHLIT IF (NLIT.GT.IDMAX) NLIT = IDMAX IF (ITEM.LE.IDMAX) NFDOL(ITEM) = 1 - L IF (NLIT.GT.IDMAX) GOTO 270 CALL KERC2U (LIT(NLIT), LBOS, 6) LIT(NLIT) = LBOS IF (LUMA.GT.0) CALL KEREQ6 (LIT(NLIT), LUSER, LUMA, NLUSER(NLIT)) IF (KEND.EQ.999) I = KEND GOTO 110 270 RETURN END SUBROUTINE KERINC (IPRX, LEND) 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, BATCH EQUIVALENCE (SWPRI, SWITCH(10)) EQUIVALENCE (BATCH, SWITCH(8)), (LIS2, IFILE(8)) CHARACTER * 64 TITLX CHARACTER * 6 L(9) DATA L / ' ', 'REMARK', 'TITLE', 'END', 'FINISH', + 'STOP', 'BATCH', ' ', 'PRINT' / DATA LMAX / 9 / CALL KEREQ6 (LIT(1), L, LMAX, LEND) IF (LEND.LE.0) GOTO 100 GOTO (1,2,3,4,4,4,7,1,9), LEND 1 IF (NFNUM.LE.0) GOTO 4 100 LEND = 0 RETURN 2 IF (IPRX .GT. 0) WRITE (IPRX, 110) CHIN(1:72) IF (IPRX .NE. LIS2) WRITE (LIS2, 110) CHIN(1:72) 110 FORMAT (' INPUT: ' , 72A, / ) GOTO 4 3 IF (TITLE.NE.' ') GOTO 4 READ (CHIN(7:72), FMT=120) TITLE 120 FORMAT (A64) DO 122 I=61,1,-1 IF (TITLE(I:I+1) .EQ. ' ') TITLX =TITLE IF (TITLE(I:I+1) .EQ. ' ') TITLE(I:64)=TITLX(I+1:64) 122 CONTINUE IF (TITLE(1:1) .EQ. ' ' ) TITLX =TITLE IF (TITLE(1:1) .EQ. ' ' ) TITLE(1:64)=TITLX(2 :64) WRITE (CHOUT, 130) TITLE 130 FORMAT (' TITLE: ', A64) CALL SHOUT2 4 RETURN 7 BATCH = .TRUE. GOTO 150 9 SWPRI = .TRUE. 150 IF (SWPRI) WRITE (LIS2, 110) CHIN(1:72) RETURN END SUBROUTINE KERINF (CHIN, I, K, FF, KEND) CHARACTER * 80 CHIN CHARACTER * 6 LL CHARACTER * 8 CHFMT M = K - I + 1 KEND = 0 CALL KERI2C (M, LL, 6) CHFMT = '(F'//LL(1:3)//'.0)' READ (CHIN(I:K), FMT = CHFMT, ERR = 99) FF RETURN 99 KEND = -1 RETURN END SUBROUTINE KERIFF (IRD, L, LMAX, LEND) 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 (LIS2, IFILE(8)) EQUIVALENCE (SWPRI, SWITCH(10)) CHARACTER * 6 L(LMAX) IPRX = 0 IF (SWPRI) IPRX = LIS2 100 CALL KERINA (IRD, L, LMAX, LEND) IF (LEND.LE.-1) RETURN CALL KERINC (IPRX, LEND) IF (LEND.EQ.0) RETURN IF (LEND.LT.4 .OR. LEND.GT.7) GOTO 100 RETURN END SUBROUTINE KETERM (KNUM, KLIT, 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 (IRD, IFILE(5)), (IPR1, IFILE(6)) DATA I / 0 / IF (KNUM.EQ.0 .AND. KLIT.EQ.0) CALL KERNER (-4, 'KETERM') READ (IRD, FMT = '(A80)', END = 105, ERR = 105) CHIN GOTO 120 105 WRITE (IPR1, 110) 110 FORMAT (' Your input line is empty' ) REWIND IRD KEND = -1 RETURN 120 CALL KERINB (LIT, 1) IF (NFNUM.GT.0 .OR. NLIT.GT.0) GOTO 140 KEND = -2 WRITE (IPR1, 130) 130 FORMAT (' Blank line' ) RETURN 140 IF ((KNUM.GE.0 .AND. NFNUM.NE.KNUM) .OR. * (KLIT.GE.0 .AND. NLIT .NE.KLIT)) THEN WRITE (IPR1, 142) KLIT, KNUM, NLIT, NFNUM 142 FORMAT (' Program requested', I3, ' literal(s) and', + I3, ' number(s)' / ' but you supplied:', I3, + ' literal(s) and', I3, ' number(s). Please, try again' /) KEND = -3 RETURN ENDIF KEND = 99 IF (NFDOL(2).NE.0) RETURN IF (NLIT.EQ.1) I = NCOLL(1) IF (NFNUM.EQ.1) I = NCOLN(1) IF (CHIN(I+1:I+1).NE.' ') RETURN CALL KERC2I (CHIN(I:I), KEND) IF (KEND.LT.0) KEND = 99 RETURN END SUBROUTINE SHOUT 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)) CHARACTER CHOUTX *72 CHOUTX = CHOUT CHOUTX(1:1) = ' ' IF (IPR1.NE.LIS1) WRITE (IPR1, 100) CHOUTX 100 FORMAT (A72) CALL SHOUT2 RETURN END SUBROUTINE SHOUT2 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)) 100 FORMAT (A72) 101 FORMAT (/A72) IF (CHOUT(1:1) .EQ. '0') THEN CHOUT(1:1) = ' ' WRITE (LIS1, 101) CHOUT IF (LIS1 .NE. LIS2) WRITE (LIS2, 101) CHOUT ELSE WRITE (LIS1, 100) CHOUT IF (LIS1 .NE. LIS2) WRITE (LIS2, 100) CHOUT ENDIF CHOUT = ' ' RETURN END SUBROUTINE FILINQ (IUNIT, FNAMEX, FFORMX, FKEYX, KINQ) CHARACTER FNAMEX *(*), FFORMX *(*), FKEYX *(*), * FNAME *64, FFORM *11, FKEY *7 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)) CHARACTER FORMIN *11, FULNAM *255, POSFMT *7, POSUNF *7, FULNA *63 LOGICAL OPN, EXS, NMD FNAME = FNAMEX CALL FILINX (FNAME) FFORM = FFORMX FKEY = FKEYX IF (FKEY.NE.'SCRATCH' .AND. FKEY.NE.'TEST' .AND. FKEY.NE.'INPUT' * .AND. FKEY.NE.'OUTPUT') THEN WRITE (CHOUT, 147) FKEY 147 FORMAT (' ERROR : ',A7,' used for SCRATCH TEST INPUT OUTPUT?') CALL SHOUT WRITE (CHOUT, 148) IUNIT 148 FORMAT (' ERROR ! other call params: UNIT=',I3,' FNAME= ') CHOUT (48:72) = FNAME CALL SHOUT CALL KERROR('Programmers error in call params', 147, 'FILINQ') ENDIF IF (IUNIT.LE.0 .OR. IUNIT.GT.20) THEN WRITE (CHOUT, 151) IUNIT 151 FORMAT (' ERROR : in call params: UNIT=', I3, ' FNAME= ') CHOUT (49:72) = FNAME CALL SHOUT CALL KERROR ('Bad file unit number', 151, 'FILINQ') ENDIF INQUIRE (FILE = FNAME, ERR = 900, IOSTAT = KINQ, EXIST = EXS, * OPENED = OPN, FORM = FORMIN, NUMBER = NUM, * NAMED = NMD, NAME = FULNAM, * FORMATTED = POSFMT, UNFORMATTED = POSUNF) IF ( EXS ) THEN IF ( OPN ) THEN IF (FORMIN .NE. FFORM ) GOTO 910 IF (NUM .NE. IUNIT ) GOTO 920 IF (FKEY .NE. 'TEST') REWIND IUNIT GOTO 200 ENDIF IF (FFORM .EQ. ' FORMATTED' .AND. POSFMT .EQ. 'NO') GOTO 930 IF (FFORM .EQ. 'FORMATTED' .AND. POSFMT .EQ. 'NO') GOTO 930 IF (FFORM .EQ. 'UNFORMATTED' .AND. POSUNF .EQ. 'NO') GOTO 932 IF (FKEY .EQ. 'SCRATCH') THEN OPEN (UNIT = IUNIT, ERR = 940, IOSTAT = KINQ, * FORM = FFORM, STATUS = 'SCRATCH') REWIND IUNIT GOTO 200 ENDIF OPEN (UNIT = IUNIT, ERR = 940, IOSTAT = KINQ, FILE = FNAME, * FORM = FFORM, STATUS = 'OLD') REWIND IUNIT 200 IF (IUNIT .EQ. IFILE(IUNIT)) IFSTAT(IUNIT) = 0 KINQ = 0 ELSE IF (FKEY .EQ. 'SCRATCH') THEN OPEN (UNIT = IUNIT, ERR = 950, IOSTAT = KINQ, * FORM = FFORM, STATUS = 'SCRATCH') ELSEIF (FKEY .EQ. 'OUTPUT') THEN OPEN (UNIT = IUNIT, ERR = 950, IOSTAT = KINQ, FILE = FNAME, * FORM = FFORM, STATUS = 'NEW') ENDIF IF (IUNIT .EQ. IFILE(IUNIT)) IFSTAT(IUNIT) = -1 KINQ = -1 ENDIF RETURN 900 WRITE (LIS1, 901) IUNIT, FNAME, KINQ 901 FORMAT ( *' ERROR Transmission error during execution of INQUIRE statement'/ * 'ERROR ? Unit number:',I3,' File name: ', A24,' Error code:',I4) GOTO 990 910 WRITE (LIS1, 911) FNAME, IUNIT, FFORM, FORMIN 911 FORMAT ( ' ERROR :', * ' The requested c.q. expected I/O-access mode of an already' / * ' ERROR !', * ' existing and opened file does not match the I/O-access mode' / * ' ERROR !', * ' found by INQUIRE for file name: ',A24, 'Unit number: ', I2 / * ' ERROR ! Requested mode: ', A11, 5X,'Mode found: ', A11) IF ( NMD ) GOTO 917 912 WRITE (LIS1, 913) 913 FORMAT (' ERROR :', * ' Full file name not returned by INQUIRE, unnamed file!') GOTO 990 917 FULNA = FULNAM WRITE (LIS1, 918) FULNA 918 FORMAT (' ERROR : Full file name: ',A63) GOTO 990 920 WRITE (LIS1, 921) FNAME, IUNIT, NUM 921 FORMAT ( ' ERROR :', * ' The requested c.q. expected unit number of an already',/, * ' ERROR !', * ' existing and opened file does not match the unit number',/, * ' ERROR ! found by INQUIRE for file name: ',A32/, * ' ERROR ! Requested unit number:',I3,5X,'Unit number found:',I3) IF ( NMD ) GOTO 917 GOTO 912 930 WRITE (LIS1, 931) FNAME, IUNIT, FFORM, POSFMT 931 FORMAT (' ERROR :', * ' The requested I/O-access mode for an already existing file' / * ' ERROR !', * ' does not match the allowed I/O-access mode for this file as' / * ' ERROR !', * ' found by INQUIRE for file name: ',A24, 'Unit number: ', I2 / * ' ERROR !', * ' Requested mode: ', A11, 5X, 'FORMATTED mode allowed: ', A7) IF ( NMD ) GOTO 917 GOTO 912 932 WRITE (LIS1, 933) FNAME, IUNIT, FFORM, POSUNF 933 FORMAT (' ERROR :', * ' The requested I/O-access mode for an already existing file' / * ' ERROR !', * ' does not match the allowed I/O-access mode for this file as' / * ' ERROR !', * ' found by INQUIRE for file name: ',A24, 'Unit number: ', I2 / * ' ERROR !', * ' Requested mode: ', A11, 5X, 'UNFORMATTED mode allowed: ', A7) IF ( NMD ) GOTO 917 GOTO 912 940 WRITE (LIS1, 941) FKEY, IUNIT, FNAME, KINQ 941 FORMAT (' ERROR :', * ' Transmission error during execution of OPEN statement' / * ' ERROR ! on an already existing file, option ', A7 / * ' ERROR !', * ' Unit number: ',I2, 4X, 'File name: ', A24, ' Error code: ',I4) GOTO 990 950 WRITE (LIS1, 951) FKEY, IUNIT, FNAME, KINQ 951 FORMAT (' ERROR :', * ' Transmission error during execution of OPEN statement' / * ' ERROR ! for a new file, option ', A7 / * ' ERROR !', * ' Unit number: ',I2, 4X, 'File name: ', A24, ' Error code: ',I4) 990 WRITE (CHOUT, 992) FNAME 992 FORMAT (' File error concerning file (name): ', A32) CALL KERROR (CHOUT, 0, 'FILINQ') END SUBROUTINE FILCLO (IUNIT, FKEYX) CHARACTER FKEYX *(*), FKEY *7 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)) LOGICAL OPN FKEY = FKEYX IF (FKEY .EQ. 'SCRATCH') FKEY = 'DELETE' IF (FKEY.NE.'KEEP'.AND.FKEY.NE.'DELETE') CALL KERNER(-4,'FILCLO') INQUIRE (UNIT = IUNIT, ERR = 200, OPENED = OPN) IF (.NOT. OPN) RETURN CLOSE (UNIT = IUNIT, ERR = 200, IOSTAT = KCLO, STATUS = FKEY) IF (KCLO.GE.1) GOTO 200 KCLO = -3 IF (FKEY.EQ.'DELETE') KCLO = -2 IF (IUNIT.EQ.IFILE(IUNIT)) IFSTAT(IUNIT) = KCLO RETURN 200 WRITE (CHOUT, 210) IUNIT, FKEY 210 FORMAT (' ERROR on closing file ', I3, ', option: ', A7) CALL KERROR (CHOUT, 0, 'FILCLO') END SUBROUTINE RDCRYS (ICRYS) 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 CHARACTER CONT*1 CHARACTER * 6 XTEST CHARACTER * 6 LLIT(30) CHARACTER * 6 NAME DATA NAME / 'RDCRYS' / DATA LLMAX / 27 / DATA LLIT / 'CRYSDA', 'CELL ', 'CELLSD', 'SPGR ', 'RCELL ', + 'VOLUM ', 'WAVE ', 'FORMUL', 'MOLW ', 'Z ', + 'NELEC ', 'F000 ', 'MU ', 'ICENT ', 'ILATT ', + 'ISYST ', 'ILAUE ', 'IMULT ', 'IUNIQ ', 'IPOLA ', + 'NTYPE ', 'NSYMM ', 'NLATT ', 'FRAC2C', 'CART2F', + 'RRMAT ', 'SSMAT ', ' ', ' ', ' ' / DATA NPRI / 0 / CALL FILINQ (ICRYS, 'CRYSDA', 'FORMATTED', 'INPUT', KINQ) IF (KINQ.EQ.-1) THEN WRITE (CHOUT, 100) CCODE 100 FORMAT (' ERROR no crysda file found for ', A6) CALL KERROR (CHOUT, 0, 'RDCRYS') ENDIF NPRI = NPRI + 1 DO 170 I=1,LLMAX CALL RDCRYB (ICRYS, LLIT(I), KEND) IF (KEND.LT.0) THEN WRITE (CHOUT, 917) LLIT(I) 917 FORMAT (' ERROR : search for keyword ', A6, * ' on CRYSDA file failed') CALL SHOUT GOTO 990 ENDIF GOTO (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, * 16,17,18,19,20,21,22,23,24, 25, 26, 27,170,170,170), I 1 IF (NPRI .EQ. 1) WRITE (LIS2, 101) 101 FORMAT (' Input crystal data file CRYSDA') CALL KERINB (LIT(32),1) IF (CCODE .EQ. ' ' .OR. CCODE .EQ. 'CCODE') CCODE = LIT(2) IF (CCODE .EQ. LIT(2)) GOTO 170 WRITE (LIS1, 102) LIT(2), CCODE 102 FORMAT (' Error: compound code on CRYSDA file is: ', A6, * ' expected: ', A6) GOTO 990 2 READ (CHIN, 130) CELL GOTO 170 3 READ (CHIN, 130) CELLSD GOTO 170 4 CONTINUE SPGR = CHIN(11:26) GOTO 170 5 READ (CHIN, 130) RCELL GOTO 170 6 READ (CHIN, 130) VOLUM GOTO 170 7 READ (CHIN, 107) WAVEAT, WAVE 107 FORMAT (10X, A2, 8X, F10.6) GOTO 170 8 READ (CHIN, 108) (CELATY(J), CELALL(J), J=1,5), CONT 108 FORMAT (10X, 5(A2, F9.2, 1X), 1X, A1) IF (CONT.EQ.'=') READ (ICRYS,108) (CELATY(J), CELALL(J), J=6,10) GOTO 170 9 READ (CHIN, 130) AMOLW GOTO 170 10 READ (CHIN, 140) IZ ZET = IZ GOTO 170 11 READ (CHIN, 140) NELEC GOTO 170 12 READ (CHIN, 130) F000 GOTO 170 13 READ (CHIN, 130) ABSMU GOTO 170 14 READ (CHIN, 140) ICENT GOTO 170 15 READ (CHIN, 140) ILATT GOTO 170 16 READ (CHIN, 140) ISYST GOTO 170 17 READ (CHIN, 140) ILAUE GOTO 170 18 READ (CHIN, 140) IMULT GOTO 170 19 READ (CHIN, 140) IUNIQ GOTO 170 20 READ (CHIN, 140) IPOLA GOTO 170 21 READ (CHIN, 140) NTYPE DO 121 J=1,NTYPE 121 CELALL(J) = CELALL(J) * ZET GOTO 170 22 READ (CHIN, 140) NSYMM DO 122 M=1,NSYMM 122 READ (ICRYS,1122) XTEST, ((IRSYMM(J,K,M),K=1,3),TSYMM(J,M),J=1,3) 1122 FORMAT (A6, 4X, 3(3I3,1X,F10.7)) IF (XTEST .NE. 'SYMMAT') GOTO 990 GOTO 170 23 READ (CHIN, 140) NLATT DO 123 M=1,NLATT 123 READ (ICRYS, 1123) XTEST, (TLATT(J,M), J=1,3) 1123 FORMAT (A6, 4X, 3(F10.7)) IF (XTEST .NE. 'CENVEC') GOTO 990 GOTO 170 24 BACKSPACE ICRYS READ (ICRYS, 150) ((FRAC2C(J,K), K=1,3), J=1,3) GOTO 170 25 BACKSPACE ICRYS READ (ICRYS, 150) ((CART2F(J,K), K=1,3), J=1,3) GOTO 170 26 BACKSPACE ICRYS READ (ICRYS, 150) ((RRMAT(J,K), K=1,3), J=1,3) GOTO 170 27 BACKSPACE ICRYS READ (ICRYS, 150) ((SSMAT(J,K), K=1,3), J=1,3) 130 FORMAT (10X, 6F10.5) 140 FORMAT (10X, I10) 150 FORMAT (3(10X, 3F15.6, /)) 170 CONTINUE IF (NPRI .NE. 1) RETURN WRITE (LIS2, 171) CELL, SPGR 171 FORMAT (' Cell', 3F8.3, 3F7.2, ' SpGr ', A16) IF (PROGNM .EQ. 'DDSTART' .OR. PROGNM .EQ. 'FFT') * WRITE (LIS1, 171) CELL, SPGR RETURN 990 WRITE (LIS1,991) LLIT(I) 991 FORMAT (' ERROR : CONTENTS OF CRYSDA FILE INCORRECT: '/ * ' ERROR ! TRYING TO READ RECORD: ', A6) CALL KERNER (-6, NAME) RETURN END SUBROUTINE RDCRYB (ICRYS, LLITX, KEND) CHARACTER LLITX *(*), LLIT *6 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 LLIT = LLITX KEND = -3 100 READ (ICRYS, 110, END=120) CHIN 110 FORMAT (A80) IF (CHIN(1:4).EQ.'END') GOTO 120 IF (CHIN(1:6).EQ.LLIT) GOTO 130 IF (CHIN(1:5).EQ.'TITLE' .AND. TITLE.EQ.' ') TITLE = CHIN(7:71) GOTO 100 120 KEND = KEND + 1 REWIND ICRYS IF (KEND.LT.-1) GOTO 100 RETURN 130 KEND = 1 RETURN END SUBROUTINE RDCRYX (ICRYS, LLITX, F, N) CHARACTER LLITX *(*), LLIT *6 DIMENSION F(N) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH 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 NAME DATA NAME / 'RDCRYX' / LLIT = LLITX CALL RDCRYB (ICRYS, LLIT, KEND) IF (KEND.LT.0) GOTO 990 M = MIN0 (6, N) READ (CHIN, 100) (F(I), I=1,M) 100 FORMAT (10X, 6F10.5) IF (N.LE.6) RETURN IF (LLIT.NE.'SFAC') GOTO 990 READ (ICRYS, 110) (F(I), I=7,N) 110 FORMAT (10X, 3F10.5, 2F7.3, F11.3, F5.2) RETURN 990 CALL KERNER (-2, NAME) RETURN END SUBROUTINE RCELLR (CELL, V, RCELL) DIMENSION CELL(6), RCELL(6), AC(6) EQUIVALENCE (AC(1), A), (AC(2), B), (AC(3), C) EQUIVALENCE (AC(4), ALPHA), (AC(5), BETA), (AC(6), GAMMA) R2D = 45. / ATAN(1.0) CALL KERNAB (CELL, AC, 6) CA = COS(ALPHA / R2D) CB = COS(BETA / R2D) CC = COS(GAMMA / R2D) SA = SQRT(1.0-CA**2) SB = SQRT(1.0-CB**2) SC = SQRT(1.0-CC**2) CASTR = (CB*CC-CA) / (SB*SC) CBSTR = (CA*CC-CB) / (SA*SC) CCSTR = (CA*CB-CC) / (SA*SB) SASTR = SQRT(1.0-CASTR**2) SBSTR = SQRT(1.0-CBSTR**2) SCSTR = SQRT(1.0-CCSTR**2) V = A*B*C * SQRT (1.0-CA*CA-CB*CB-CC*CC+2.0*CA*CB*CC) RCELL(1) = B*C*SA / V RCELL(2) = A*C*SB / V RCELL(3) = A*B*SC / V RCELL(4) = ASIN(SASTR) * R2D RCELL(5) = ASIN(SBSTR) * R2D RCELL(6) = ASIN(SCSTR) * R2D IF (CASTR .LT. 0.0) RCELL(4) = 180.0 - RCELL(4) IF (CBSTR .LT. 0.0) RCELL(5) = 180.0 - RCELL(5) IF (CCSTR .LT. 0.0) RCELL(6) = 180.0 - RCELL(6) RETURN END SUBROUTINE CELLRR (CELL, RR) DIMENSION CELL(6), RR(3,3) R2D = 45. / ATAN(1.0) CA = COS(CELL(4) / R2D) CB = COS(CELL(5) / R2D) CC = COS(CELL(6) / R2D) RR(1,1) = CELL(1) * CELL(1) RR(1,2) = CELL(1) * CELL(2) * CC RR(1,3) = CELL(1) * CELL(3) * CB RR(2,1) = RR(1,2) RR(2,2) = CELL(2) * CELL(2) RR(2,3) = CELL(2) * CELL(3) * CA RR(3,1) = RR(1,3) RR(3,2) = RR(2,3) RR(3,3) = CELL(3) * CELL(3) RETURN END SUBROUTINE CELZAT (ACELTY, NCELTY, NCELLZ) DIMENSION ACELTY(10), NCELTY(10), NCELLZ(10) CHARACTER ACELTY *2 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 /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 JCELLZ(10) DO 160 N = 1, NTYPE 160 CALL ATOMIZ(CELATY(N), K, JCELLZ(N)) DO 180 N = 1, 10 NCELLZ(N) = 0 NCELTY(N) = 0 180 ACELTY(N) = ' ' LZ = 999 DO 580 N = 1, NTYPE DO 570 J = 1, NTYPE IF (JCELLZ(J) .GE. LZ) GOTO 570 IF (JCELLZ(J) .EQ. NCELLZ(N)) * NCELTY(N) = NCELTY(N) + NINT(CELALL(J)) IF (JCELLZ(J) .GT. NCELLZ(N)) THEN NCELLZ(N) = JCELLZ(J) NCELTY(N) = NINT(CELALL(J)) ACELTY(N) = CELATY(J) ENDIF 570 CONTINUE 580 LZ = NCELLZ(N) WRITE (LIS2, 611) (ACELTY(I), I=1,NTYPE) 611 FORMAT (' Cell contents. Atoms: ', 10(3X, A2)) WRITE (LIS2, 612) (NCELLZ(I), I=1,NTYPE) 612 FORMAT (17X, 'Z = : ', 10I5) WRITE (LIS2, 613) (NCELTY(I), I=1,NTYPE) 613 FORMAT (' Total number of atoms: ', 10I5) RETURN END SUBROUTINE BINIX (IFI, FILENM, NIT, NW1, BUF) CHARACTER FILENM *(*), FILEN *6 PARAMETER (MAXBUF = 198) DIMENSION BUF(MAXBUF) 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 (LIS2, IFILE(8)) FILEN = FILENM CALL FILINQ (IFI, FILEN, 'UNFORMATTED', 'INPUT', KINQ) IF (KINQ.LT.0) THEN WRITE (CHOUT, FMT='(''Binary input file '', * A6, 1X, A6, '' not found'')') CCODE, FILEN CALL KERROR (CHOUT, 0, 'BINIX') ENDIF IF (SWPRI) WRITE (LIS2, 100) FILEN 100 FORMAT (' Read binary data file ', A6) CALL KERNZA (0., BUF, MAXBUF) READ (IFI, ERR=120, IOSTAT=IFSTAT(IFI)) * NW, NIT, NRR, NW1, CHIN, (BUF(I), I=1,NW1) IF (CHIN(1:6) .NE. FILEN) THEN WRITE (CHOUT, 105) FILEN, CHIN(1:6) 105 FORMAT (' Warning: filename conflict, file: ', A6, * ' interal i.d.: ', A6) CALL SHOUT ENDIF IF (IFSTAT(IFI) .EQ. 0) RETURN 120 WRITE (CHOUT, 130) FILENM, IFI 130 FORMAT (' Error input file ', A6, ', unit number ', I3) CALL KERROR (CHOUT, 120, 'BINIX') RETURN END SUBROUTINE BINOX (IFO, FILENM, NIT, NW1, BUF) CHARACTER FILENM *(*), FILEN *6 PARAMETER (MAXBUF = 198) DIMENSION BUF(MAXBUF) 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 (LIS2, IFILE(8)) FILEN = FILENM CALL FILINQ (IFO, FILEN, 'UNFORMATTED', 'OUTPUT', KINQ) IF (SWPRI) WRITE (LIS2, 100) FILEN 100 FORMAT (' Write binary data file ', A6) IF (NW1 .GT. MAXBUF-24) CALL KERNER (100, 'BINOX') NW = MAXBUF NRR = MAXBUF / NIT DO 110 I=1,4 110 BUF(I) = ITIME(I) CHIN(1 :6) = FILEN CHIN(7 :12) = CCODE CHIN(13:20) = PROGNM CHIN(21:80) = TITLE WRITE (IFO, ERR=120, IOSTAT=IFSTAT(IFO)) * NW, NIT, NRR, NW1, CHIN, (BUF(I), I=1,NW1) IF (MAXBUF .GT. NW1) CALL KERNZA (0., BUF(NW1+1), MAXBUF-NW1) IF (IFSTAT(IFO) .EQ. 0) RETURN 120 WRITE (CHOUT, 130) FILENM, IFO 130 FORMAT (' Error output file ', A6, ', unit number ', I3) CALL KERROR (CHOUT, 0, 'BINOX') RETURN END SUBROUTINE BINIFF (KEY, IFI, FILENM, FITEMS, NIT, BUF, NEND) CHARACTER FILENM *(*), FILEN *6 PARAMETER (MAXBUF = 198) DIMENSION BUF(MAXBUF) 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 DIMENSION FITEMS (1) DATA FSTOP / -66.9E06 / IF (IFI.LE.0 .OR. IFI.GT.20) CALL KERROR (' IFI?',-4,'BINIFF') IF (KEY) 140, 110, 100 100 FILEN = FILENM CALL BINIX (IFI, FILEN, NIT, NW1, BUF) NEND = - NW1 RETURN 110 IF (NEND.LT.0) GOTO 115 IF (NEND.LE.MAXBUF-NIT) GOTO 120 115 READ (IFI, ERR=150, END=150, IOSTAT=IFSTAT(IFI)) BUF IF (IFSTAT(IFI) .NE. 0) GOTO 150 NEND = 0 120 IF (BUF(NEND+1).LE.FSTOP) GOTO 130 CALL KERNAB (BUF(NEND+1), FITEMS, NIT) NEND = NEND + NIT RETURN 130 NEND = -NEND IF (NEND.GE.0) NEND = -999 140 RETURN 150 WRITE (CHOUT, 160) FILENM, IFI 160 FORMAT (' Error reading input file ', A6, ', unit number ', I3) CALL KERROR (CHOUT, 0, 'BINIFF') END SUBROUTINE BINOFF (KEY, IFO, FILENM, FITEMS, NIT, BUF, NEND) CHARACTER FILENM *(*), FILEN *6 PARAMETER (MAXBUF = 198) DIMENSION BUF(MAXBUF) 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 DIMENSION FITEMS (NIT) DATA FSTOP / -67.0E06 / IF (IFO.LE.0 .OR. IFO.GT.20) CALL KERROR (' IFO?',-4,'BINOFF') IF (KEY) 120, 110, 100 100 NW1 = MIN0(MAXBUF, MAX0(KEY,4)) IF (NW1.GT.4) GOTO 101 NW1 = 5 BUF(5) = 0. 101 FILEN = FILENM CALL BINOX (IFO, FILEN, NIT, NW1, BUF) GOTO 140 110 CALL KERNAB (FITEMS, BUF(NEND+1), NIT) NEND = NEND + NIT IF (NEND .LE. MAXBUF-NIT) RETURN GOTO 130 120 BUF(NEND+1) = FSTOP CALL KERNZA (0.0, BUF(NEND+2), MAXBUF-NEND-1) 130 CONTINUE WRITE (IFO, ERR=150, IOSTAT=IFSTAT(IFO)) BUF 140 NEND = - IFSTAT(IFO) IF (NEND.LT.0) GOTO 150 RETURN 150 WRITE (CHOUT, 160) FILENM, IFO 160 FORMAT (' Error writing output file ', A6, ', unit number ', I3) CALL KERROR (CHOUT, 0, 'BINOFF') RETURN END SUBROUTINE ATOMIZ (LM, NLET, IZ) CHARACTER * 2 LM, L, LL, LLC, LLLC DIMENSION L(100), LLC(100), LLLC(100) DATA L / 'H ', 'HE', 'LI', 'BE', 'B ', 'C ', 'N ', 'O ', 'F ', * 'NE', 'NA', 'MG', 'AL', 'SI', 'P ', 'S ', 'CL', 'AR', 'K ', * 'CA', 'SC', 'TI', 'V ', 'CR', 'MN', 'FE', 'CO', 'NI', 'CU', * 'ZN', 'GA', 'GE', 'AS', 'SE', 'BR', 'KR', 'RB', 'SR', 'Y ', * 'ZR', 'NB', 'MO', 'TC', 'RU', 'RH', 'PD', 'AG', 'CD', 'IN', * 'SN', 'SB', 'TE', 'I ', 'XE', 'CS', 'BA', 'LA', 'CE', 'PR', * 'ND', 'PM', 'SM', 'EU', 'GD', 'TB', 'DY', 'HO', 'ER', 'TM', * 'YB', 'LU', 'HF', 'TA', 'W ', 'RE', 'OS', 'IR', 'PT', 'AU', * 'HG', 'TL', 'PB', 'BI', 'PO', 'AT', 'RN', 'FR', 'RA', 'AC', * 'TH', 'PA', 'U ', 'NP', 'PU', 'AM', 'CM', 'BK', 'CF', 'ES', * 'FM' / DATA LLC / 'H ', 'He', 'Li', 'Be', 'B ', 'C ', 'N ', 'O ', 'F ', * 'Ne', 'Na', 'Mg', 'Al', 'Si', 'P ', 'S ', 'Cl', 'Ar', 'K ', * 'Ca', 'Sc', 'Ti', 'V ', 'Cr', 'Mn', 'Fe', 'Co', 'Ni', 'Cu', * 'Zn', 'Ga', 'Ge', 'As', 'Se', 'Br', 'Kr', 'Rb', 'Sr', 'Y ', * 'Zr', 'Nb', 'Mo', 'Tc', 'Ru', 'Rh', 'Pd', 'Ag', 'Cd', 'In', * 'Sn', 'Sb', 'Te', 'I ', 'Xe', 'Cs', 'Ba', 'La', 'Ce', 'Pr', * 'Nd', 'Pm', 'Sm', 'Eu', 'Gd', 'Tb', 'Dy', 'Ho', 'Er', 'Tm', * 'Yb', 'Lu', 'Hf', 'Ta', 'W ', 'Re', 'Os', 'Ir', 'Pt', 'Au', * 'Hg', 'Tl', 'Pb', 'Bi', 'Po', 'At', 'Rn', 'Fr', 'Ra', 'Ac', * 'Th', 'Pa', 'U ', 'Np', 'Pu', 'Am', 'Cm', 'Bk', 'Cf', 'Es', * 'Fm' / DATA LLLC / 'h ', 'he', 'li', 'be', 'b ', 'c ', 'n ', 'o ', 'f ', * 'ne', 'na', 'mg', 'al', 'si', 'p ', 's ', 'cl', 'ar', 'k ', * 'ca', 'sc', 'ti', 'v ', 'cr', 'mn', 'fe', 'co', 'ni', 'cu', * 'zn', 'ga', 'ge', 'as', 'se', 'br', 'kr', 'rb', 'sr', 'y ', * 'zr', 'nb', 'mo', 'tc', 'ru', 'rh', 'pd', 'ag', 'cd', 'in', * 'sn', 'sb', 'te', 'i ', 'xe', 'cs', 'ba', 'la', 'ce', 'pr', * 'nd', 'pm', 'sm', 'eu', 'gd', 'tb', 'dy', 'ho', 'er', 'tm', * 'yb', 'lu', 'hf', 'ta', 'w ', 're', 'os', 'ir', 'pt', 'au', * 'hg', 'tl', 'pb', 'bi', 'po', 'at', 'rn', 'fr', 'ra', 'ac', * 'th', 'pa', 'u ', 'np', 'pu', 'am', 'cm', 'bk', 'cf', 'es', * 'fm' / IZ = -1 CALL KERC2I (LM(2:2), KEND1) NLET = 1 IF (KEND1.GT.10 .AND. KEND1.LT.37) NLET = 2 LL = LM(1:NLET) IF (LL .EQ. 'Q' .OR. LL .EQ. 'q') LL = 'H' IF (LL.EQ.'D' .OR. LL.EQ.'T') LL = 'H' IF (LL.EQ.'d' .OR. LL.EQ.'t') LL = 'H' DO 100 I=1,100 IF (LL.EQ.L(I) .OR. LL.EQ.LLC(I) .OR. LL.EQ.LLLC(I)) GOTO 110 100 CONTINUE RETURN 110 IZ = I RETURN END SUBROUTINE ATOMCH (IZ) 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 IF (NFDOL(2).GE.0) GOTO 150 I = NCOLL(2) CALL ATOMIZ (CHIN(I:I+1), NLET, IZ) IF (IZ .LE. 0) GOTO 150 I = I + NLET IF (CHIN(I:I).NE.' ') GOTO 110 IF (NFDOL(3).EQ.2) RETURN IF (NFDOL(3).LE.0) GOTO 150 K = NCOLN(1) IF (CHIN(K:K).EQ.'+' .OR. CHIN(K:K).EQ.'-') RETURN IF (K-I.GT.4) GOTO 150 IF (NFNUM .EQ. 3) RETURN CHOUT(I:NCOLN(2)-1) = CHIN(K:NCOLN(2)-1) CHIN(I:NCOLN(2)-1) = CHOUT(I:NCOLN(2)-1) CHOUT = ' ' CALL KERINB (LIT(32),1) RETURN 110 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 RETURN 150 CALL KERROR (' Incorrect atomic symbol', -6, 'ATOMCH') END SUBROUTINE ATOMIN (IFAT, ATXYZ, ATNAME, IZAT, MAXAT, NAT, KEYT) 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 EQUIVALENCE (IPR1, IFILE(6)), (LIS1, IFILE(7)) 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 CHIN2 *80 99 FORMAT (/' DIRDIF cannot proceed:'/ * ' the input ATOMS or ATMOD file is incorrect:'/ * ' maybe a leftover of a preceding error stop? MSG:') IF (IFAT.LE.0 .OR. IFAT.GT.20) CALL KERROR (' IFAT?',-4,'ATOMIN') READ (IFAT, 105, ERR = 940, END = 940, IOSTAT = IFSTAT(IFAT)) * CHIN(1:72) 105 FORMAT (A72) CHIN2 = CHIN CALL KERINB (LIT, 1) IF (LIT(1) .NE. 'ATMOD' .AND. LIT(1) .NE. 'ATOMS' * .AND. LIT(1) .NE. 'ATLIT' ) GOTO 951 IF (LIT(1) .EQ. 'ATOMS' .AND. LIT(2) .NE. CCODE) GOTO 953 IF (LIT(1) .EQ. 'ATLIT' .AND. LIT(2) .NE. CCODE) GOTO 953 LEND = 999 NAT = 1 107 CALL ATOMIA (IFAT, ATXYZ, ATNAME, IZAT, MAXAT, NAT, LEND) IF (LEND.NE.0) GOTO 200 NAT = NAT + 1 IF (NAT .EQ. MAXAT) CALL KERROR ('Too many atoms', -6, 'ATOMIN') GOTO 107 200 NAT = NAT - 1 IF (NAT .LE. 0) GOTO 955 IF (LEND .LT. 0) THEN CHOUT = ' Warning ATOMS or ATMOD file: END card missing' CALL SHOUT ENDIF CALL ATOMST (0, ATXYZ, NAT, KEYT) DO 302 I = 1, NAT IF (ATNAME(I) (1:1) .EQ. 'Q') THEN ATXYZ(4,I) = 0.0 ATXYZ(5,I) = 0.0 ENDIF 302 CONTINUE CHIN = CHIN2 CALL KERINB (LIT, 1) RETURN 940 WRITE (LIS1, 99) WRITE (IPR1, 99) CALL KERROR('File error reading ATOMS or ATMOD file', 0,'ATOMIN') 951 WRITE (LIS1, 99) WRITE (IPR1, 99) CALL KERROR * ('No file identification on ATOMS or ATMOD file', -6,'ATOMIN') 953 WRITE (LIS1, 99) WRITE (IPR1, 99) CALL KERROR ('Incorrect CCODE on ATOMS file', -6,'ATOMIN') 955 WRITE (LIS1, 99) WRITE (IPR1, 99) CALL KERROR * ('No atoms found on ATOMS or ATMOD file', -6, 'ATOMIN') END SUBROUTINE ATOMIA (IFAT, ATXYZ, ATNAME, IZAT, MAXAT, NAT, LEND) 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 CHIN2 *80 , LITA(4) *6 DATA LITA /'ATOM', 'BIJ', 'ATESD', 'BIJESD' / DATA LEND2 / 0 / IF (LEND .EQ. 999) THEN CALL KERIFF (IFAT, LITA, 4, LEND) IF (LIT(1).NE.'ATOM') CALL KERROR * ('First atom on ATOMS or ATMOD file not: ATOM', -6, 'ATOMIA') ELSE CHIN = CHIN2 LEND = LEND2 CALL KERINB (LIT, 1) ENDIF IF (LEND.NE.0) RETURN CALL ATOMCH (IZAT(NAT)) ATNAME(NAT) = LIT(2) DO 110 I = 1, NSLOT IF (I.LE.3 .AND. NCOLN(I).LE.0) CALL KERROR * ('Data on atoms card not correct', -6, 'ATOMIA') 110 ATXYZ(I,NAT) = FNUM(I) 117 CALL KERIFF (IFAT, LITA, 4, LEND) IF (LEND .NE. 0) GOTO 201 GOTO (201, 202, 203, 204), NLUSER(1) CALL KERROR * ('Record on ATOMS or ATMOD file not recognised', -6, 'ATOMIA') 201 CHIN2 = CHIN LEND2 = LEND LEND = 0 RETURN 202 CALL KERNAB (FNUM, ATXYZ(5,NAT), 6) GOTO 117 203 CALL KERNAB (FNUM, ATXYZ(1,NAT+1), 5) GOTO 117 204 CALL KERNAB (FNUM, ATXYZ(5,NAT+1), 6) GOTO 117 END SUBROUTINE ATOMPR (IPRX, NAPR, ATXYZ, ATNAME, IZAT, NAT) DIMENSION ATXYZ(10,NAT), IZAT(NAT), ATNAME(NAT) CHARACTER *6 ATNAME NATX = (NAPR * 5 + 1) / 2 IF (NATX .GT. NAT) NATX = NAT IF (NATX .LT. NAT) NATX = NAPR IF (NATX .LE. 0) NATX = MIN0 (3, NAT) WRITE (IPRX, FMT='('' Number of atoms stored:'', I4)') NAT KEYT = 1 DO 102 I=1,NATX IF (ATXYZ(4,I) .LT. 0.999 .OR. ATXYZ(5,I) .GT. 0.0001) KEYT = 2 IF (ATXYZ(6,I) .GT. 0.000001) GOTO 103 102 CONTINUE IF (KEYT .EQ. 1) WRITE (IPRX, FMT=' * ('' Atom name x y z'', 8X,''Z'')') IF (KEYT .EQ. 2) WRITE (IPRX, FMT=' ('' Atom name x'', * '' y z'', 8X,''Z occ.f. B'')') GOTO 104 103 WRITE (IPRX, FMT=' ('' Atom name x'', * '' y z'', 8X,''Z occ.f. B.equiv.'')') 104 DO 109 I=1,NATX IF (ATXYZ(4,I) .LT. 0.999 .OR. ATXYZ(5,I) .GT. 0.0001) THEN WRITE (IPRX, 106) ATNAME(I), (ATXYZ(J,I),J=1,3), IZAT(I), * (ATXYZ(J,I),J=4,5) 106 FORMAT (3X, A6, 2X, 3F9.5, I4, 2F9.4) ELSE WRITE (IPRX, 106) ATNAME(I), (ATXYZ(J,I),J=1,3), IZAT(I) ENDIF 109 CONTINUE IF (NAT .GT. NATX) WRITE (IPRX, FMT='('' Printing of remaining'', * '' atoms supressed.'')') RETURN END SUBROUTINE ATOMWR (IATOMS, ATXYZ, ATNAME, NAT) DIMENSION ATXYZ(10,NAT), ATNAME(NAT) CHARACTER *6 ATNAME 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)) CHARACTER FATOMX * 6 FATOMX = 'ATOMS' IF (SWITCH(25)) FATOMX = 'ATMOD' CALL ATOMWA (IATOMS) DO 109 NATR = 1, NAT 109 CALL ATOMWB (IATOMS, ATXYZ, ATNAME, NATR) WRITE (LIS2, 120) FATOMX, NAT 120 FORMAT (' Number of atoms written to ', A6, 'file:', I4) WRITE (IATOMS, FMT = '(''END'')') RETURN END SUBROUTINE ATOMWA (IATOMS) 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 IT = MAX0 (0, 10000 * (ITIME(1)-1900) + 100 * ITIME(2) + ITIME(3)) IF (SWITCH(25)) THEN WRITE (IATOMS, 101) PROGNM, IT, KEYS(13) 101 FORMAT ('ATMOD CART generated by program ', * A8, ' date', I7, ' RUN', I4) ELSEIF (FNUM(32) .LT. 0.0001) THEN WRITE (IATOMS, 102) CCODE, PROGNM, IT, KEYS(13) 102 FORMAT ('ATOMS ', A6, ' generated by program ', * A8, ' date', I7, ' RUN', I4) ELSE WRITE (IATOMS, 103) CCODE, PROGNM, IT, KEYS(13), FNUM(32) 103 FORMAT ('ATOMS ', A6, ' gener. progr. ', * A8, ' date', I7, ' RUN', I4, ' SC=', F12.7) FNUM(32) = 0.0 ENDIF IF (CHOUT .NE. ' ') THEN WRITE (IATOMS, FMT = '(''REMARK '', A65)') CHOUT(1:65) CHOUT = ' ' ENDIF RETURN END SUBROUTINE ATOMWB (IATOMS, ATXYZ, ATNAME, NATR) DIMENSION ATXYZ(10,NATR), ATNAME(NATR) CHARACTER *6 ATNAME 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 DIMENSION BEQ(1) BEQ(1) = ATXYZ(5,NATR) IF (ATXYZ(5,NATR) .GT. 0.00001 .AND. ATXYZ(6,NATR) .GT. 0.00001) * CALL ATBEQ (ATXYZ(1,NATR), BEQ, 1) IF ((ATXYZ(4,NATR) .GT. 0.00001 .AND. ABS(ATXYZ(4,NATR)-1.) * .GT. 0.00001) .OR. ATXYZ(5,NATR) .GT. 0.00001) THEN WRITE (IATOMS, 104) ATNAME(NATR), (ATXYZ(J,NATR), J=1,4), BEQ 104 FORMAT ('ATOM ', A6, 2X, 3F9.5, 2F8.4) ELSE WRITE (IATOMS, 104) ATNAME(NATR), (ATXYZ(J,NATR), J=1,3) ENDIF IF (ATXYZ(5,NATR) .GT. 0.00001 .AND. ATXYZ(6,NATR) .GT. 0.00001) * WRITE (IATOMS, 108) ATNAME(NATR), (ATXYZ(J,NATR), J = 5,10) 108 FORMAT ('BIJ ', A6, 2X, 6F9.5) RETURN END SUBROUTINE ATOMST (KEY, ATXYZ, NAT, KEYT) PARAMETER (NSLOT = 10) DIMENSION ATXYZ(NSLOT,NAT) PARAMETER (U2B = 8. * 3.141593 **2) FAC = U2B IF (KEY .EQ. 1) FAC = 1. / U2B KEYT = 1 DO 200 I=1,NAT IF (ABS(ATXYZ(4,I)).LT.0.000001) ATXYZ(4,I) = 1.0 IF (ATXYZ(5,I).LT.0.000001) THEN ATXYZ(5,I) = 0.0 ATXYZ(6,I) = -0.000001 GOTO 150 ENDIF IF (ATXYZ(6,I).GT.0.000001) THEN KEYT = 3 ELSE ATXYZ(6,I) = -0.000001 ENDIF IF (KEYT.EQ.1) KEYT = 2 150 IF (KEY .EQ. 0) GOTO 200 IF (ABS(ATXYZ(5,I)) .LT. 0.000001) GOTO 200 ATXYZ(5,I) = ATXYZ(5,I) * FAC IF (ATXYZ(6,I) .LE. 0.) GOTO 200 DO 180 J=6, NSLOT 180 ATXYZ(J,I) = ATXYZ(J,I) * FAC 200 CONTINUE RETURN END SUBROUTINE ATOMOC (KEY, ATXYZ, MSELF, NAT) PARAMETER (NSLOT = 10) DIMENSION ATXYZ(NSLOT,NAT), MSELF(NAT) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION XYZ(3) DO 150 I=1,NAT N = 0 DO 140 IL=1,NLATT DO 140 J=1,NSYMM DO 120 K=1,3 120 XYZ(K) = TSYMM(K,J) + TLATT(K,IL) * + ATXYZ(1,I) * IRSYMM(K,1,J) * + ATXYZ(2,I) * IRSYMM(K,2,J) * + ATXYZ(3,I) * IRSYMM(K,3,J) N = N + ISELFD (ATXYZ(1,I), XYZ, 0.04) IF (ICENT.EQ.1) GOTO 140 DO 130 IC=1,3 130 XYZ(IC) = -XYZ(IC) N = N + ISELFD (ATXYZ(1,I), XYZ, 0.04) 140 CONTINUE IF (KEY .EQ. 0) MSELF(I) = N IF (KEY .EQ. 1) ATXYZ(4,I) = ATXYZ(4,I) / FLOAT(N) IF (KEY .LE. 1) GOTO 150 ATXYZ(4,I) = ATXYZ(4,I) * FLOAT(N) IF (ABS (ATXYZ(4,I) - 1.0) .LT. 0.0001) ATXYZ(4,I) = 1.0 150 CONTINUE RETURN END SUBROUTINE ATBEQ (ATXYZ, BEQ, NAT) PARAMETER (NSLOT = 10) DIMENSION ATXYZ(NSLOT,NAT), BEQ(NAT) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION SI(3), CO(3), SISI(6) LOGICAL CONT DATA CONT /.FALSE./ DATA R4 / 0.0 / IF (NAT .GT. 1) CONT = .FALSE. IF (CONT) GOTO 133 CONT = .TRUE. RAD = 57.295789 DO 100 I=4,6 SI(I-3) = SIN(CELL(I)/RAD) CO(I-3) = COS(CELL(I)/RAD) IF (ABS(CELL(I)-90.).LT.0.0001) CO(I-3)=0.0 100 CONTINUE R4 = 1.0 DO 110 I=1,3 110 R4 = R4 - CO(I)**2 R4 = (R4 + (2. * CO(1) * CO(2) * CO(3))) * 3. DO 130 I=1,3 SISI(I) = SI(I)**2 DO 130 J=1,3 IF (J - I) 130, 130, 120 120 SISI(9-I-J) = SI(I) * SI(J) * 2.0 * CO(6-I-J) 130 CONTINUE 133 DO 150 M=1,NAT B = 0.0 DO 140 I=1,6 140 B = B + SISI (I) * ATXYZ(I+4,M) 150 BEQ(M) = B / R4 RETURN END SUBROUTINE ATBETA (ATXYZ, NAT) PARAMETER (NSLOT = 10) DIMENSION ATXYZ(NSLOT,NAT) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION RLP(3), RLP2(6) DATA IFIRST /0/ IFIRST = IFIRST + 1 DO 200 K=1,3 RLP(K) = SQRT(SSMAT(K,K)) 200 RLP2(K) = SSMAT(K,K) RLP2(4) = RLP(2) * RLP(3) * 2. RLP2(5) = RLP(1) * RLP(3) * 2. RLP2(6) = RLP(1) * RLP(2) * 2. DO 220 I=1,NAT IF (ATXYZ(6,I).LE.0.0) GOTO 220 DO 210 J=5,10 210 ATXYZ(J,I) = ATXYZ(J,I) * RLP2(J-4) 220 CONTINUE RETURN END SUBROUTINE CELZIN (ATXYZ, IZAT, NAT, NCELLZ, NCELIN) DIMENSION ATXYZ(10,NAT), IZAT(NAT), NCELLZ(10), NCELIN(10) 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 /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION IOCC(1) CALL KERNZI (0, NCELIN, 10) DO 590 I = 1, NAT CALL ATOMOC (0, ATXYZ(1,I), IOCC(1), 1) NN = NINT (ATXYZ(4,I) * FLOAT (IMULT/IOCC(1))) DO 585 N = 1, NTYPE IF (NCELLZ(N) .NE. IZAT(I)) GOTO 585 NCELIN(N) = NCELIN(N) + NN GOTO 590 585 CONTINUE IF (IZAT(I) .LE. 1) GOTO 590 CALL KERROR * (' Input atom type not defined by CRYSDA', 585, 'CELZIN') 590 CONTINUE WRITE (LIS2, 614) (NCELIN(I), I=1,NTYPE) 614 FORMAT (' Number of atoms input: ', 10I5) RETURN END SUBROUTINE RDCOND (IRDX, L, LMAX, KEND) CHARACTER * 6 L(LMAX) 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)) LOGICAL FIRST EQUIVALENCE (SWITCH(9), FIRST) PARAMETER (NCHMAX=517) COMMON / / DUMMY(1), CHONDA(NCHMAX) CHARACTER * 80 CHONDA DIMENSION BLACOM(42000) EQUIVALENCE (BLACOM(1), DUMMY(1)) CHARACTER * 6 PROLD LOGICAL CONDA DATA CONDA, PROLD / .TRUE., ' ' / DATA NCH, NCHA, KDAT / 0, 0, 0 / KEND = -2 IF (.NOT. CONDA) RETURN IF (PROLD .NE. ' ') GOTO 300 CALL FILINQ (IRDX, 'CONDA', 'FORMATTED', 'INPUT', KINQ) IF (KINQ.EQ.-1) THEN WRITE (LIS2, 190) CCODE 190 FORMAT (' Control data file: ', A6,' CONDA not present') CONDA = .FALSE. RETURN ENDIF CALL KERINA (IRDX, LIT, 1, LEND) IF (LEND.NE.0 .OR. LIT(1).NE.'CONDA' .OR. LIT(2).EQ.' ') * CALL KERROR ('ERROR on first record of CONDA file', 0, 'RDCOND') IF (CCODE .EQ. ' ') CCODE = LIT(2) WRITE (LIS2, 230) 230 FORMAT (' Input control data file CONDA') IF (CCODE .NE. LIT(2)) THEN WRITE (CHOUT, 250) CCODE, LIT(2) 250 FORMAT ('ERROR: CCODE = ', A6,' but on CONDA file it is ', A6) CALL KERROR (CHOUT, 0, 'RDCOND') ENDIF NCH = 1 NCHA = 1 CHONDA(NCH) = CHIN CALL KERINA (IRDX, LIT, 1, LEND) IF (LEND.LT.0 .OR. LEND.GE.5) THEN WRITE (CHOUT, FMT='('' Empty CONDA file ...... '')') CALL SHOUT CONDA = .FALSE. CALL FILCLO (IRDX, 'DELETE') RETURN ENDIF PROLD = '$DUMMY' IF (LIT(1) .EQ. 'TITLE') THEN IF (TITLE(1:64) .NE. CHIN(7:70)) THEN TITLE = CHIN(7:80) WRITE (LIS1, FMT='('' RUN TITLE: '', A64)') TITLE WRITE (LIS2, FMT='('' RUN TITLE: '', A64)') TITLE ENDIF NCH = 2 NCHA = 2 CHONDA(NCH) = CHIN ELSE BACKSPACE IRDX ENDIF 290 CALL KERINA (IRDX, L, LMAX, LEND) IF (LEND .LT. 0 .OR. LEND .GE. 5) THEN WRITE (LIS2, 295) L(1) 295 FORMAT (' Requested record: PROGRAM ', A6 / * ' not found in CONDA file ' ) PROLD = ' ' KEND = -1 CALL FILCLO (IRDX, 'KEEP') RETURN ENDIF IF (LIT(1).NE.'PROGRA' .OR. LIT(2).NE.L(1)) GOTO 290 KDAT = 0 KEND = 1 RETURN 300 KEND = 0 CALL KERIFF (IRDX, L, LMAX, KSTOP) IF (KSTOP .LT. 0) GOTO 807 IF (KSTOP .GE. 5) GOTO 803 IF (KSTOP .NE. 0) GOTO 801 IF (LIT(1).EQ.'PROGRA') GOTO 803 IF (KDAT .EQ. 0) THEN WRITE (LIS2, 320) CCODE 320 FORMAT (' Input from control data file CONDA for compound ', A6) KDAT = 1 ENDIF WRITE (LIS2, 322) CHIN(1:72) 322 FORMAT (' Input: ' , A72) IF (NLUSER(1).LE.0) CALL KERROR (' Unidentified control card', * 0, 'RDCOND') KEND = NLUSER(1) RETURN 801 CALL KERINA (IRDX, LIT(32), 1, LEND) IF (LEND .EQ. -1) GOTO 807 803 NCH = NCH + 1 IF (LIT(1) .EQ. 'STOP' .OR. LIT(1) .EQ. 'FINISH') NCHA = NCHA+1 IF (NCH .GE. NCHMAX) CALL KERROR ('CONDA too big', 801, 'RDCOND') CHONDA(NCH) = CHIN IF (LIT(1) .NE. 'STOP' .AND. LIT(1) .NE. 'FINISH') GOTO 801 807 REWIND IRDX DO 808 I = 1, NCH 808 WRITE (IRDX, FMT = '(A80)') CHONDA(I) REWIND IRDX IF (NCHA .GE. NCH) THEN CALL FILCLO (IRDX, 'DELETE') CONDA = .FALSE. ENDIF PROLD =' ' RETURN END SUBROUTINE RDDCON 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 (IRDX, IFILE(1)) PARAMETER ( LMAX = 3 ) CHARACTER * 6 L(LMAX) DATA L / 'DDOKA' , 'MSDOS', ' ' / CALL FILINQ (IRDX, 'DDCON', 'FORMATTED', 'INPUT', KINQ) IF ( KINQ .NE. 0 ) THEN RETURN ENDIF CALL KERINA (IRDX, LIT, 1, LEND) IF (LEND.NE.0 .OR. LIT(1).NE.'DDCON') THEN GOTO 999 ENDIF 300 CALL KERIFF (IRDX, L, LMAX, LEND) IF (LEND .LT. 0 .OR. LEND .GE. 4) GOTO 999 KEND = NLUSER(1) IF ( KEND .LE. 0 ) GOTO 300 GOTO ( 1, 2, 3 ), KEND 1 CONTINUE IF (LIT(2) .NE. '=YES') THEN GOTO 300 ENDIF KEYS(10) = -17 KEYS(9) = -17 KEYS(8) = -17 GOTO 300 2 CONTINUE GOTO 300 3 CONTINUE GOTO 300 999 CALL FILCLO (IRDX, 'KEEP') RETURN END SUBROUTINE LOGWR (IDDL) 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)), (LIS1, IFILE(7)) EQUIVALENCE (LIS2, IFILE(8)) EQUIVALENCE (IRUN, KEYS(13)) LOGICAL BATCH, FULAUT EQUIVALENCE (BATCH, SWITCH(8)), (FULAUT, SWITCH(12)) CHARACTER*56 CHOUT2 DATA IFIRST / 0 / IFIRST = IFIRST + 1 CHOUT2 = CHOUT IT = 0 IF (ITIME(1) .GT. 0) * IT = 10000 * (ITIME(1)-1900) + 100 * ITIME(2) + ITIME(3) CALL FILINQ (IDDL, 'DDLOG', 'FORMATTED', 'OUTPUT', KINQ) IF (KINQ.EQ.0) GOTO 220 WRITE (IDDL, 200) CCODE, IT 200 FORMAT ('DDLOG ', A6,' GENERATION DATE ', I7,' DO NOT DESTROY') WRITE (LIS1, 201) IT WRITE (LIS2, 201) IT 201 FORMAT (' DDLOG file: GENERATION DATE ', I7,' DO NOT DESTROY') IF (BATCH .OR. FULAUT) GOTO 215 210 WRITE (IPR1, FMT='('' Welcome to DIRDIF Wonderland'' / * '' Please give TITLE (will be stored in DDLOG file):'')') CALL KETERM (-1, -1, KEND) IF (KEND.LT.0) GOTO 210 TITLE = CHIN 215 CHOUT = ' Welcome to DIRDIF Wonderland' CALL SHOUT2 IF (TITLE .NE. ' ') THEN WRITE (IDDL, FMT='(''TITLE '', A64)') TITLE WRITE (LIS1, FMT='('' LOG TITLE: '', A64)') TITLE WRITE (LIS2, FMT='('' LOG TITLE: '', A64)') TITLE ENDIF CHOUT = 'RUN 1' WRITE (IDDL, 217) PROGNM, IT, CHOUT(1:56) 217 FORMAT (A8, I7, 1X, A56) WRITE (LIS1, FMT='(A)') * ' Note: DDLOG is used for communication between various programs' CHOUT = ' ' IRUN = 1 IF (CHOUT2 .EQ. ' ') RETURN GOTO 250 220 READ (IDDL, FMT='(A3)', END=230) CHIN(1:3) IF (CHIN(1:3).NE.'END') GOTO 220 GOTO 245 230 WRITE (LIS1, 240) 240 FORMAT (' Warning: no END record found on the DDLOG file') 245 BACKSPACE IDDL 250 WRITE (IDDL, 260) PROGNM, IT, CHOUT2 260 FORMAT (A8, I7, 1X, A56 / 'END' / 'END') IF (IFIRST .EQ. 1) WRITE (LIS2, FMT='(1X)') WRITE (LIS2, 262) PROGNM, IT, CHOUT2 262 FORMAT (' Control data for DDLOG:' * / 1X, A8, I7, 1X, A56) CHOUT = ' ' RETURN END SUBROUTINE LOGRD (IDDL, LITX, KLOG) CHARACTER LITX *(*) CHARACTER LITS(1) *6 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)) EQUIVALENCE (IPR1, IFILE(6)) EQUIVALENCE (LIS1, IFILE(7)) CHARACTER CHINX *72 CALL FILINQ (IDDL, 'DDLOG', 'FORMATTED', 'INPUT', KLOG) IF (KLOG.EQ.-1) RETURN ICOUNT = 0 IREGEL = 0 LITS(1) = LITX 200 CALL KERINA (IDDL, LITS, 1, LEND) ICOUNT = ICOUNT + 1 IF (LEND .EQ. -1) WRITE (LIS1, * FMT='('' Warning: no END marker on the DDLOG file'')' ) IF (LEND .NE. 0) GOTO 230 DO 210 I=1,NLIT IF (NLUSER(I).EQ.1) GOTO 220 210 CONTINUE GOTO 200 220 KLOG = I IREGEL = ICOUNT CHINX = CHIN GOTO 200 230 IF (KLOG .EQ. 0) RETURN CHIN = CHINX CALL KERINB (LITS, 1) REWIND (IDDL) DO 300 I=1,IREGEL 300 READ (IDDL,FMT='(A1)') RETURN END SUBROUTINE COPY80 (IIN, FIN, IOUT, FOUT) CHARACTER FIN *(*), FOUT *(*), FINX *7, FOUTX *7 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 (KEYS(13), IRUN) EQUIVALENCE (LIS1, IFILE(7)) CHARACTER LAST *6 FINX = FIN FOUTX = FOUT LAST = ' ' IF (IIN.LE.0 .OR. IIN.GT.20 .OR. FIN.EQ.' ') CALL KERROR * ('No input unit number or no file name given', 0, 'COPY80') IF (IOUT.LE.0 .OR. IOUT.GT.20 .OR. FOUT.EQ.' ') CALL KERROR * ('No output unit number or no file name given', 0, 'COPY80') CALL FILINQ (IIN, FINX, 'FORMATTED', 'INPUT', KINQ) IF (KINQ .NE. 0) RETURN CALL FILINQ (IOUT, FOUTX, 'FORMATTED', 'OUTPUT', KINQ) IF (KINQ .EQ. -1) THEN IF (FOUT .EQ. 'ATOLD') * WRITE (IOUT, 142) CCODE, (ITIME(I), I=1,3), IRUN, CCODE 142 FORMAT ('ATOLD ', A6, ' file (= ATOMS OLD) created: DAY', * I5, 2I3, ' RUN', I4 / * ' Note: for proper reuse of old atomic parameters:'/ * ' select wanted header record (ATOMS ', A6, '), and'/ * ' copy it with following records up to (incl.) END'/ * ' to the ATOMS file'/) IF (FOUT .NE. 'ATOLD') * WRITE (IOUT, 144) FOUT, CCODE, (ITIME(I),I=1,3), IRUN, CCODE 144 FORMAT ('REMARK : ', A6, 1X, A6, ' file created: DAY', * I5, 2I3, ' RUN', I4 ) GOTO 200 ENDIF NR = 0 150 READ (IOUT, 202, END=180, ERR=250) CHIN NR = NR + 1 IF (CHIN(1:6) .NE. 'FINISH') THEN LAST = CHIN(1:6) GOTO 150 ENDIF BACKSPACE IOUT GOTO 190 180 REWIND IOUT DO 182 I = 1, NR 182 READ (IOUT, 202) 190 IF (LAST .NE. 'END ') WRITE (IOUT, FMT='(''END'')') WRITE (IOUT, 192) PROGNM, (ITIME(I), I=1,3), IRUN 192 FORMAT (/ 'Next file appended by program ', A8, * ' DAY', I5, 2I3, ' RUN', I4 /) 200 N = 0 READ (IIN, 202, END=210, ERR=270) CHIN 202 FORMAT (A80) N = N + 1 WRITE (IOUT, 202) CHIN IF (CHIN(1:6) .NE. 'FINISH') GOTO 200 210 IF (CHIN(1:6) .NE. 'FINISH') WRITE (IOUT, FMT='(''FINISH'')') REWIND IIN REWIND IOUT CALL FILCLO (IOUT, 'KEEP') RETURN 250 WRITE (CHOUT, 280) FOUTX, IOUT GOTO 282 270 WRITE (CHOUT, 280) FINX, IIN 280 FORMAT (' Error reading file ', A7, ', unit number ', I3) 282 CALL KERROR (CHOUT, 0, 'COPY80') RETURN END SUBROUTINE VALDIS (KEY, V1, V2, KARR, KM, KEND) DIMENSION KARR(KM) DATA VINC, VBOT, VTOP, VSUB, VMIN / 0.0, 0.0, 0.0, 0.0, 0.0 / IF (KEY) 100, 110, 140 100 KEND = 0 CALL KERNZI (0, KARR, KM) VMIN = V1 VMAX = V2 VINC = (V2 - V1) / (KM - 2) VSUB = VMIN - VINC - VINC GOTO 130 110 KEND = KEND + 1 IF (KEND.GT.1) GOTO 120 VBOT = V1 VTOP = V1 120 IF (V1.GT.VTOP) VTOP = V1 IF (V1.LT.VBOT) VBOT = V1 KAD = IFIX( (V1 - VSUB) / VINC ) IF (KAD.LE.0) KAD = 1 IF (KAD.GT.KM) KAD = KM KARR(KAD) = KARR(KAD) + 1 130 RETURN 140 IF (VINC.GT.0.) GOTO 150 VSUB = VBOT VBOT = VTOP VTOP = VSUB 150 KE = KEND - KEY V1 = VBOT IF (KE.LE.0) GOTO 130 KSOM = 0 DO 160 KAD=1,KM KSOM = KSOM + KARR(KAD) IF (KSOM.GE.KE) GOTO 170 160 CONTINUE 170 A2 = VMIN + KAD*VINC - VINC A1 = A2 - VINC IF (KAD.EQ.1) A1 = VBOT IF (KAD.EQ.KM) A2 = VTOP V1 = A1 + ((A2-A1) * (KE-KSOM+KARR(KAD))) / KARR(KAD) GOTO 130 END SUBROUTINE LINPRI (KEY, FITEMS, NIT) DIMENSION FITEMS(NIT) COMMON /SYSTA/ IFILE(20), IFSTAT(20), ITIME(4), KEYS(28), * NFNUM, NLIT, NCOLN(32), NCOLL(32), * NFDOT(32), NFDOL(32), NLUSER(32), FNUM(32), * SWITCH(28) LOGICAL SWITCH COMMON /SYSTB/ PROGNM, PROSNM, CCODE, TITLE, * CHIN, LIT(32), CHOUT CHARACTER PROGNM *8, PROSNM *6, CCODE *6, TITLE *64, * CHIN *80, LIT *6, CHOUT *72 CHARACTER PRFORM *72 PARAMETER (MAXBUF = 100) DIMENSION BUF(MAXBUF) DATA NUMNIT, NITMAX, IPR / 0, 0, 0 / IF (NIT.GT.MAXBUF .OR. NIT.LE.0) CALL KERROR * (' Incorrect number of itmes send to LINPRI', 0, 'LINPRI') IF (KEY) 240, 220, 200 200 IPR = KEY PRFORM = CHOUT CHOUT = ' ' NITMAX = NIT 210 CALL KERNZA (0., BUF, NITMAX) NUMNIT = 0 RETURN 220 IF (NUMNIT+NIT.GT.NITMAX) THEN WRITE (IPR, FMT=PRFORM) (BUF(IBUF),IBUF=1,NUMNIT) CALL KERNZA (0., BUF, NITMAX) NUMNIT = 0 ENDIF DO 230 I=1,NIT 230 BUF(NUMNIT+I) = FITEMS(I) NUMNIT = NUMNIT + NIT RETURN 240 IF (NUMNIT.GT.0) WRITE (IPR, FMT=PRFORM) (BUF(IBUF),IBUF=1,NUMNIT) GOTO 210 END SUBROUTINE XHELP (IHELP, IPRX, XLAB) 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)) 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 DATA IN, NLAB /0, 1000000/ IF (IHELP .LE. 0) THEN IF (IN .GT. 0) CALL FILCLO (IN, 'KEEP') IN = -1 RETURN ENDIF XLAB5 = XLAB - 0.0005 110 CONTINUE IF (IN .NE. IHELP) THEN IN = IHELP NLAB = 1000000 CALL FILCLO (IHELP, 'KEEP') CALL FILINQ (IHELP, 'DDHELP', 'FORMATTED', 'INPUT', KINQ) IF (KINQ .EQ. 0) GO TO 110 CHOUT = ' File DIRDIF.DDHELP not found' CALL SHOUT CALL KERROR (' DDHELP missing ', 0, 'XHELP') ENDIF LAB = NINT (1000. * XLAB) IF (LAB .LE. 0 .OR. LAB .GE. 1000000) THEN CHOUT = ' Help call range error' CALL SHOUT CALL KERROR (' DDHELP file error ', 0, 'XHELP') ENDIF IF (LAB .GT. NLAB) GOTO 220 REWIND IN 200 READ (IHELP, 210, END=980, ERR=990) CHIN(1:72) 210 FORMAT (A72) IF (CHIN(1:7) .NE.'$XPRINT') GOTO 200 220 READ (IHELP, 210, END=980, ERR=990) CHIN(1:72) IF (CHIN(1:1) .NE. '+') GOTO 220 IF (CHIN(1:2) .EQ. '++') GOTO 220 CALL KERINB (LIT, 1) IF (XLAB5 .GT. FNUM(1)) GOTO 220 NLAB = NINT (1000. * FNUM(1)) IF (NLAB .NE. LAB) GOTO 980 I = NCOLL(1) - 1 IF (I .LE. 0) I =72 CHIN (1:I) = ' ' IF (I .LT. 72) I = I + 1 CHOUT = CHIN(I:72) CHIN = CHOUT CHOUT = ' ' 310 WRITE (IPRX, 312) CHIN (1:72) 312 FORMAT (1X, A72) READ (IHELP, 210, END=980, ERR=990) CHIN(1:72) IF (CHIN(1:1) .NE. '+') GO TO 310 BACKSPACE IHELP RETURN 980 WRITE (CHOUT, FMT='('' Requested label'', * '' not found on DDHELP file'')') CALL SHOUT WRITE (LIS2, FMT='('' Exit key '', F8.3)') XLAB 990 CALL KERROR ('Error reading DDHELP file', 990, 'XHELP') END FUNCTION ISELFD (X, Y, DMAX) DIMENSION X(3), Y(3) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION DM(3), D(3) DATA DMOLD /-999.0/ DATA DMAXSQ / 0.0 / IF (ABS (DMOLD - DMAX) .GT. 0.0001) THEN DO 100 I=1, 3 100 DM(I) = DMAX * RCELL(I) DMOLD = DMAX DMAXSQ = DMAX * DMAX ENDIF ISELFD=0 DO 120 I=1, 3 D(I) = X(I) - Y(I) - ANINT (X(I)-Y(I)) IF (ABS (D(I)) .GT. DM(I)) RETURN 120 CONTINUE CALL VMATV1 (D, RRMAT, D, DIST2) IF (DIST2 .LE. DMAXSQ) ISELFD = 1 RETURN END SUBROUTINE DISTSQ (X, Y, DMAX, Z, DIST2) DIMENSION X(3), Y(3), Z(3) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION DM(3) DATA DMOLD /-9999.9/ IF (ABS (DMOLD - DMAX) .GT. 0.0001) THEN DO 100 I=1, 3 100 DM(I) = DMAX * RCELL(I) DMAXSQ = DMAX * DMAX DMOLD=DMAX ENDIF DIST2 = 9999.9 DO 120 I=1, 3 Z(I) = Y(I) - X(I) - ANINT (Y(I)-X(I)) IF (ABS (Z(I)) .GT. DM(I)) RETURN 120 CONTINUE CALL VMATV1 (Z, RRMAT, Z, DIST2) RETURN END SUBROUTINE SYMOP1 (IS, X, XS) DIMENSION X(3), XS(3) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION RSYMM(3,3,24) LOGICAL CONT DATA CONT / .FALSE. / IF (CONT) GOTO 200 CONT = .TRUE. CALL KERI2F (IRSYMM, RSYMM, 9 * NSYMM) 200 IF (IS .EQ. 1) THEN CALL KERNAB (X, XS, 3) ELSE CALL MATXV3 (RSYMM(1,1,IS), X, XS) XS(1) = XS(1) + TSYMM(1,IS) XS(2) = XS(2) + TSYMM(2,IS) XS(3) = XS(3) + TSYMM(3,IS) ENDIF END SUBROUTINE SYMOP2 (IC, IL, XS, XST) DIMENSION XS(3), XST(3) 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) IF (IC .EQ. 1) THEN XST(1) = TLATT(1,IL) + XS(1) XST(2) = TLATT(2,IL) + XS(2) XST(3) = TLATT(3,IL) + XS(3) ELSE XST(1) = TLATT(1,IL) - XS(1) XST(2) = TLATT(2,IL) - XS(2) XST(3) = TLATT(3,IL) - XS(3) ENDIF END FUNCTION ISELFX (X, Y, DMAX) DIMENSION X(3), Y(3) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION DM(3), D(3) DATA DMOLD /-999.0/ DATA DMAXSQ / 0.0 / IF (ABS (DMOLD - DMAX) .GT. 0.0001) THEN DO 100 I=1, 3 100 DM(I) = DMAX * RCELL(I) DMOLD = DMAX DMAXSQ = DMAX * DMAX ENDIF ISELFX=0 DO 120 I=1, 3 D(I) = X(I) - Y(I) - ANINT (X(I)-Y(I)) IF (ABS (D(I)).GT.DM(I)) RETURN 120 CONTINUE CALL VMATV1 (D, RRMAT, D, DISTSQ) IF (DISTSQ .LE. DMAXSQ) THEN DO 130 I = 1,3 130 Y(I) = Y(I) + ANINT( X(I)-Y(I) ) ISELFX = 1 ENDIF RETURN END SUBROUTINE LOCKIN (ATIN, DMAX, ATOUT, DIST, NPOS) DIMENSION ATIN(3), ATOUT(3), D(3) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION XYZ(3), XYZC(3), TPOS(3,48) LOGICAL CENTRO, AGAIN DATA CENTRO / .FALSE. / DATA DELTA / 0.0001 / AGAIN = .FALSE. IF ( ICENT .EQ. 2 ) CENTRO = .TRUE. CALL KERNZA ( 0.0, ATOUT, 3 ) CALL KERNAB (ATIN, TPOS, 3) NPOS = 1 NADD = 0 120 DO 200 I = 1,NPOS DO 190 JT = 1,NLATT DO 190 J = 1,NSYMM IF ( CENTRO ) AGAIN = .TRUE. DO 130 K = 1,3 XYZ(K) = TSYMM(K,J) + TLATT(K,JT) + * TPOS(1,I) * IRSYMM(K,1,J) + * TPOS(2,I) * IRSYMM(K,2,J) + * TPOS(3,I) * IRSYMM(K,3,J) 130 XYZC(K) = -XYZ(K) 140 IF ( ISELFX (ATIN, XYZ, DMAX) .EQ. 1 ) THEN DO 150 L = 1,NPOS+NADD IF ( ( ABS(XYZ(1)-TPOS(1,L)) .LT. DELTA ) .AND. * ( ABS(XYZ(2)-TPOS(2,L)) .LT. DELTA ) .AND. * ( ABS(XYZ(3)-TPOS(3,L)) .LT. DELTA ) ) GOTO 170 150 CONTINUE NADD = NADD + 1 IF ( NPOS+NADD .GT. 48 ) CALL KERROR * ('Program symm. error?', 150, 'LOCKIN') DO 160 K = 1,3 160 TPOS(K,NPOS+NADD) = XYZ(K) ENDIF 170 IF ( .NOT. CENTRO ) GOTO 190 IF ( AGAIN ) THEN DO 180 K = 1,3 180 XYZ(K) = XYZC(K) AGAIN = .FALSE. GOTO 140 ENDIF 190 CONTINUE 200 CONTINUE IF ( NADD .EQ. 0 ) GOTO 220 NPOS = NPOS + NADD NADD = 0 GOTO 120 220 DIST = 0.0 FNPOS = FLOAT(NPOS) DO 240 I = 1,3 DO 230 K = 1,NPOS 230 ATOUT(I) = ATOUT(I) + TPOS(I,K) 240 ATOUT(I) = ATOUT(I) / FNPOS IF ( NPOS .LE. 1 ) GOTO 260 DO 250 I = 1,3 250 D(I) = ATIN(I) - ATOUT(I) CALL VMATV1( D, RRMAT, D, DIST ) DIST = SQRT( DIST ) 260 RETURN END SUBROUTINE HKLSTL (HKL, STL, STL2) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION HKL(3) STL2 = 0.0 DO 100 I =1,3 DO 100 J =1,3 100 STL2 = STL2 + HKL(I) * SSMAT(I,J) * HKL(J) STL2 = STL2 / 4.0 STL = SQRT(STL2) RETURN END SUBROUTINE HKLEXS (SWITCH, HKL, HCODE) LOGICAL SWITCH DIMENSION HKL(3) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION RSYMM(3,3,24), HHH(3) LOGICAL IRSW DATA IRSW / .FALSE. / IF (IRSW) GOTO 110 IRSW = .TRUE. CALL KERI2F (IRSYMM, RSYMM, 9*NSYMM) 110 DO 200 J = 1,NSYMM DO 120 K = 1,3 HHH(K) = HKL(1) * RSYMM(1,K,J) * + HKL(2) * RSYMM(2,K,J) * + HKL(3) * RSYMM(3,K,J) 120 CONTINUE CALL HKLC1 (HHH, HC) IF (SWITCH) HC = ABS(HC) IF (J.EQ.1) HCODE = HC HCODE = AMAX1 (HC, HCODE) 200 CONTINUE RETURN END SUBROUTINE HKLEXT (HKL, KEND) DIMENSION HKL(3) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION KSYMM(3,3,24), TT(3,24), III(3), KKK(3) LOGICAL IRSW, SKIP DATA IRSW , SKIP / .FALSE. , .FALSE. / DATA NST / 0 / IF (SKIP) GOTO 102 IF (IRSW) GOTO 110 IF (NSYMM.GT.1) GOTO 103 101 SKIP = .TRUE. 102 KEND = 0 RETURN 103 IRSW = .TRUE. NST = 0 DO 104 J = 2,NSYMM IF (ABS(TSYMM(1,J)) .LT. 0.01 .AND. * ABS(TSYMM(2,J)) .LT. 0.01 .AND. * ABS(TSYMM(3,J)) .LT. 0.01) GOTO 104 NST = NST + 1 CALL KERNAI (IRSYMM(1,1,J), KSYMM(1,1,NST), 9) CALL KERNAB (TSYMM(1,J), TT(1,NST), 3) 104 CONTINUE IF (NST.EQ.0) GOTO 101 110 CALL KERF2I (HKL, III, 3) DO 200 J = 1,NST TEST = 0. DO 120 K = 1,3 KKK(K) = III(1) * KSYMM(1,K,J) * + III(2) * KSYMM(2,K,J) * + III(3) * KSYMM(3,K,J) 120 CONTINUE IF (III(1).EQ.KKK(1) .AND. III(2).EQ.KKK(2) .AND. * III(3).EQ.KKK(3) ) GOTO 130 IF (ICENT.EQ.1) GOTO 200 IF (III(1).NE.-KKK(1) .OR. III(2).NE.-KKK(2) .OR. * III(3).NE.-KKK(3) ) GOTO 200 130 TEST = TT(1,J) * HKL(1) + TT(2,J) * HKL(2) + TT(3,J) * HKL(3) IF (AMOD (ABS(TEST)+0.01, 1.0) .LT. 0.02) GOTO 200 KEND = -1 RETURN 200 CONTINUE KEND = 0 RETURN END SUBROUTINE HKLEX1 (HKL, HKLX) DIMENSION HKL(3), HKLX(3,24) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION RSYMM(3,3,24) LOGICAL IRSW DATA IRSW / .FALSE. / IF (IRSW) GOTO 110 IRSW = .TRUE. CALL KERI2F (IRSYMM, RSYMM, 9*NSYMM) 110 CALL KERNAB (HKL, HKLX, 3) IF (NSYMM.EQ.1) RETURN DO 120 J = 2,NSYMM DO 120 K = 1,3 120 HKLX(K,J) = HKL(1) * RSYMM(1,K,J) * + HKL(2) * RSYMM(2,K,J) * + HKL(3) * RSYMM(3,K,J) RETURN END SUBROUTINE HKLEX2 (HKL, IDHKL, IEPS, IEPS2) DIMENSION HKL(3,24), IDHKL(24) 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) IDHKL(1) = 0 IF (NSYMM.EQ.1) THEN IEPS = 1 IEPS2 = 1 RETURN ENDIF IEPS = 0 IEPS2 = 0 DO 300 J=2,NSYMM IDHKL(J) = 0 DO 200 K=1,J-1 IF (ABS(HKL(1,K)-HKL(1,J)) .GT. 0.1) GOTO 180 IF (ABS(HKL(2,K)-HKL(2,J)) .GT. 0.1) GOTO 180 IF (ABS(HKL(3,K)-HKL(3,J)) .GT. 0.1) GOTO 180 IDHKL(J) = K IEPS = IEPS + 1 GOTO 300 180 CONTINUE IF (ABS(HKL(1,K)+HKL(1,J)) .GT. 0.1) GOTO 200 IF (ABS(HKL(2,K)+HKL(2,J)) .GT. 0.1) GOTO 200 IF (ABS(HKL(3,K)+HKL(3,J)) .GT. 0.1) GOTO 200 IDHKL(J) = - K IEPS2 = IEPS2 + 1 GOTO 300 200 CONTINUE 300 CONTINUE IEPS2 = NSYMM / (NSYMM - IEPS - IEPS2) IF (ICENT .EQ. 1) THEN IEPS = NSYMM / (NSYMM - IEPS) ELSE IEPS = IEPS2 ENDIF RETURN END SUBROUTINE HKLEX3 (HKL, IDHKL, PSHIFT) DIMENSION HKL(3), IDHKL(24), PSHIFT(24) 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) CALL KERNZA (0., PSHIFT, NSYMM) IF (NSYMM .EQ. 1) RETURN DO 220 I=1,NSYMM IF (IDHKL(I) .NE. 0) GOTO 210 XTEST = 0.0 DO 200 J=1,3 200 XTEST = XTEST - HKL(J) * TSYMM(J,I) XTEST = AMOD(XTEST,1.0) IF (XTEST .LT. -0.01) XTEST = XTEST + 1. PSHIFT(I) = XTEST * 360. GOTO 220 210 ITEST = IABS(IDHKL(I)) PSHIFT(I) = PSHIFT(ITEST) 220 CONTINUE RETURN END SUBROUTINE HKLAXT (HKL, KEND) DIMENSION HKL(3) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, + WAVE, CELALL(10), AMOLW, ZET, + NELEC, F000, ABSMU, ICENT, + ILATT, ISYST, ILAUE, IMULT, + IUNIQ, IPOLA, NTYPE, NSYMM, + IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), + FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION IH(3) CALL KERF2I (HKL, IH, 3) GOTO (200, 2, 3, 4, 5, 6, 7), ILATT 2 I = IH(2) + IH(3) GOTO 100 3 I = IH(1) + IH(3) GOTO 100 4 I = IH(1) + IH(2) GOTO 100 5 I = IH(1) + IH(2) + IH(3) 100 IF (MOD(I,2) .EQ. 0) GOTO 200 GOTO 150 6 IF (MOD (IH(1)+IH(2),2) .EQ. 0 .AND. * MOD (IH(1)+IH(3),2) .EQ. 0) GOTO 200 GOTO 150 7 IF (MOD (-IH(1)+IH(2)+IH(3),3) .EQ. 0) GOTO 200 150 KEND = -1 RETURN 200 CONTINUE KEND = 0 RETURN END SUBROUTINE HKLC1 (HKL, HCODE) DIMENSION HKL(3), HKL1(3) PARAMETER (ADD = -99., SPANL = 200., SPANKL = 200. * 200., * LSPAN = 200 , KLSPAN = 200 * 200, * IDDHKL = 99 * (KLSPAN + LSPAN + 1) ) HCODE = HKL(1) * SPANKL + HKL(2) * SPANL + HKL(3) RETURN ENTRY HKLC1U (HCODE1, HKL1) KCODE = NINT (HCODE1) + IDDHKL I = KCODE / KLSPAN HKL1(1) = FLOAT (I) + ADD M = MOD(KCODE,KLSPAN) I = M / LSPAN HKL1(2) = FLOAT (I) + ADD M = MOD(KCODE, LSPAN) HKL1(3) = FLOAT (M) + ADD RETURN END SUBROUTINE HKLC2 (HKL, ACODE) DIMENSION HKL(3), HKL1(3), HMIN(3), HMAX(3) DIMENSION ADD(3) DATA SPANL, SPANKL, LSPAN, KLSPAN, IDDHKL / 0.0, 0.0, 0, 0, 0 / ACODE = HKL(1) * SPANKL + HKL(2) * SPANL + HKL(3) RETURN ENTRY HKLC2U (ACODE1, HKL1) KCODE = IFIX (ACODE1) + IDDHKL HKL1(1) = FLOAT ( KCODE /KLSPAN) + ADD(1) HKL1(2) = FLOAT ( MOD(KCODE,KLSPAN) / LSPAN) + ADD(2) HKL1(3) = FLOAT ( MOD(KCODE, LSPAN) ) + ADD(3) RETURN ENTRY HKLC2I (HMIN, HMAX) CALL KERNAB (HMIN, ADD, 3) SPANL = HMAX(3) - HMIN(3) + 1. SPANKL = SPANL * (HMAX(2) - HMIN(2) + 1.) LSPAN = IFIX (SPANL + 0.1) KLSPAN = IFIX (SPANKL + 0.1) ADDHKL = - HMIN(1) * SPANKL * - HMIN(2) * SPANL - HMIN(3) IDDHKL = NINT (ADDHKL) RETURN END SUBROUTINE FCALCI (KEYT, ATXYZ, IZAT, ITAT, NAT) DIMENSION ATXYZ(10,NAT), IZAT(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 (ICRYS, IFILE(3)) 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) 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)) DO 130 I=1,NTYPE CALL RDCRYB (ICRYS, 'ELEM' , KEND) IF (KEND.LE.0) THEN WRITE (CHOUT, 110) I 110 FORMAT (' CRYSDA file: ELEM for atom TYPE no. ',I2,' not found') CALL KERROR (CHOUT, 0, 'FCALCI') ENDIF READ (CHIN, 120) IZTYPE(I) 120 FORMAT (10X, 2X, I8) 130 CALL RDCRYX (ICRYS, 'SFAC' , SFAC(1,I), 13) DO 150 I=1,NSYMM IF (ABS(TSYMM(1,I)).GT.0.001 .OR. * ABS(TSYMM(2,I)).GT.0.001 .OR. * ABS(TSYMM(3,I)).GT.0.001 ) THEN ITRS(I) = 1 ELSE ITRS(I) = 0 ENDIF 150 CONTINUE AMULT = FLOAT (IMULT) ASYMM = FLOAT (NSYMM) ALATT = FLOAT (NLATT) ASYMCL= FLOAT (ICENT*NLATT) NSYMC = NSYMM * ICENT ASYMC = FLOAT (NSYMC) IF (.NOT. EXPAND) CALL ATOMOC (1, ATXYZ, ITAT, NAT) CALL KERNZA (0.0, CELPAR, NTYPE) AAMULT = AMULT IF (EXPAND) AAMULT = ALATT DO 161 I=1,NAT DO 160 J=1,NTYPE IF (IZAT(I).NE.IZTYPE(J)) GOTO 160 ITAT(I) = J CELPAR(J) = CELPAR(J) + ATXYZ(4,I) * AAMULT 160 CONTINUE 161 CONTINUE IF (KEYT.EQ.3) CALL ATBETA (ATXYZ, NAT) CALL SICOT (SICO, 12500) ISMAX = IFIX (STLMAX * 400. +0.04 ) + 2 IF (ISMAX.LE.500) GOTO 200 WRITE (CHOUT, 198) STLMAX 198 FORMAT (' Found max. sin(th/lam) = STLMAX =', F7.3, * ' Max = 1.249 . ??DATA ERROR?? ') CALL KERROR (CHOUT, 0, 'FCALCI') 200 DO 260 IS=1,ISMAX STL = FLOAT(IS-1) * 0.0025 STL2 = STL * STL EXPBP(IS) = EXP(-BP * STL2) EXPBR(IS) = EXP(-BR * STL2) SUMF2(IS) = 0.0 SUMF2P(IS) = 0.0 DO 260 I=1,NTYPE SFAC6 = AMIN1 (SFAC(6,I) * STL2, 99.99) SFAC8 = AMIN1 (SFAC(8,I) * STL2, 99.99) FF(IS,I) = SFAC(9,I) + SFAC(10,I) * + SFAC(1,I) * EXP (-SFAC(2,I) * STL2) * + SFAC(3,I) * EXP (-SFAC(4,I) * STL2) * + SFAC(5,I) * EXP (-SFAC6) + SFAC(7,I) * EXP (-SFAC8) SUMF2(IS) = SUMF2(IS) + FF(IS,I) * FF(IS,I) * CELALL(I) 260 SUMF2P(IS) = SUMF2P(IS)+ FF(IS,I) * FF(IS,I) * CELPAR(I) PSQ = SUMF2P(2)/SUMF2(2) P1SQ = PSQ / ASYMC IF (.NOT. EXPAND) RETURN P1SQ = PSQ PSQ = AMIN1 (0.999 , P1SQ * ASYMC) RETURN END SUBROUTINE SICOT (SICO, M) DIMENSION SICO(M) PARAMETER (PI2 = 2.0 * 3.14159265 ) M1 = M / 5 M2 = M1 * 2 M4 = M2 * 2 F = PI2 / FLOAT(M4) DO 240 I=1,M1 AI = SIN (FLOAT(I) * F) SICO(I) = AI SICO(M2-I) = AI SICO(M2+I) =-AI SICO(M4-I) =-AI 240 SICO(M4+I) = AI SICO(M2) = 0.0 SICO(M4) = 0.0 RETURN END SUBROUTINE MACOL(A) DIMENSION A(3,3) N=1 105 K=2 110 T=A(K,N) A(K,N)=A(N,K) A(N,K)=T IF (N.EQ.3) RETURN K=K+1 IF (K.LE.3) GOTO 110 N=3 GOTO 105 END SUBROUTINE MATINV(A,B,D,KEND) DIMENSION A(3,3),B(3,3) PARAMETER (DETMAX = 10.E-15) KEND=0 CALL VECAXB (A(1,2),A(1,3),B(1,1)) CALL VECAXB (A(1,3),A(1,1),B(1,2)) CALL VECAXB (A(1,1),A(1,2),B(1,3)) D=A(1,1)*B(1,1)+A(2,1)*B(2,1)+A(3,1)*B(3,1) IF (D.LT.DETMAX .AND. D.GT.-DETMAX) KEND = -99 IF (KEND.EQ.-99) RETURN DO 15 N=1,3 DO 15 K=1,3 15 B(K,N)=B(K,N)/D CALL MACOL(B) RETURN END FUNCTION ERFU (X) DIMENSION E(31) DATA E / .00000, .11246, .22270, .32863, .42839, * .52050, .60386, .67780, .74210, .79691, * .84270, .88021, .91031, .93401, .95229, * .96611, .97635, .98379, .98909, .99279, * .99532, .99702, .99814, .99886, .99931, * .99959, .99976, .99987, .99992, .99996, .99998 / X10 = X*10. + 1.00001 IX = X10 IF (IX.GT.30) GOTO 100 ERFU = E(IX) + (X10-IX) * (E(IX+1)-E(IX)) RETURN 100 ERFU = 1. RETURN END FUNCTION IPHFIX (HKL) COMMON /CRYSA/ CELL(6), CELLSD(6), RCELL(6), VOLUM, * WAVE, CELALL(10), AMOLW, ZET, * NELEC, F000, ABSMU, ICENT, * ILATT, ISYST, ILAUE, IMULT, * IUNIQ, IPOLA, NTYPE, NSYMM, * IRSYMM(3,3,24), TSYMM(3,24), NLATT, TLATT(3,4), * FRAC2C(3,3), CART2F(3,3), RRMAT(3,3), SSMAT(3,3) DIMENSION HKL(3), ICODE(13), LTEST(3), IHKL(3) DATA ICODE / 2, -1, 9, 8, 7, -1, 6, -1, 5, 4, 3, -1, 2 / CALL KERF2I (HKL, IHKL, 3) IF(ICENT.EQ.1) GOTO 150 IPHFIX = 2 RETURN 150 IPHFIX = 1 IOLD = -1 DO 180 I=2,NSYMM XTEST = 0.0 KTEST = 0 DO 170 J=1,3 LTEST(J) = 0 DO 160 L=1,3 160 LTEST(J) = LTEST(J) + IHKL(L)*IRSYMM(L,J,I) KTEST = KTEST + IHKL(J) + LTEST(J) IF (KTEST.NE.0) GOTO 180 170 XTEST = XTEST - (HKL(J) * TSYMM(J,I)) XTEST = XTEST - IFIX(XTEST) IF (XTEST.LT.-0.01) XTEST = XTEST + 1.0 IPHS = IFIX(12.*XTEST+0.1) + 1 IPHFIX = ICODE(IPHS) IF (IOLD.EQ.-1) IOLD = IPHFIX IF (IPHFIX.NE.IOLD) GOTO 190 180 CONTINUE IF (IPHFIX.GE.1) RETURN 190 IPHFIX = -1 RETURN END FUNCTION E2EXP (ITYP, E1, E2) EX1 = E1 * E1 EX2 = E2 * E2 IF (ITYP.NE.0) GOTO 100 Q = (EX2-EX1) / 2.0 E2EXP = EX1 + Q * (1. - SIMW(Q)) RETURN 100 EXX1 = EXP(-EX1*.5) EX3 = EXX1 / (EXX1 + EXP(-EX2*.5) ) E2EXP = EX1*EX3 + (1.0 - EX3)*EX2 RETURN END FUNCTION SIMW (Q) SIMW = ((0.0106 * Q - 0.1304) * Q + 0.5658) * Q IF (Q.GT.5.) SIMW=0.8565 + 0.0075*Q RETURN END SUBROUTINE MATC2F (CELL, CX) DIMENSION CELL(6), CX(3,3) DIMENSION CELLT(6) EQUIVALENCE (A ,CELLT(1)), (B ,CELLT(2)) EQUIVALENCE (C ,CELLT(3)), (ALPH,CELLT(4)) EQUIVALENCE (BET ,CELLT(5)), (GAMM,CELLT(6)) CALL KERNAB (CELL, CELLT, 6) D2R = ATAN(1.0) / 45.0 ALPHA = ALPH * D2R BETA = BET * D2R GAMMA = GAMM * D2R COSA = COS(ALPHA) SINA = SIN(ALPHA) COSB = COS(BETA) SINB = SIN(BETA) COSC = COS(GAMMA) SINC = SIN(GAMMA) S = 0.5*(ALPHA+BETA+GAMMA) V = A*B*C *2. *SQRT(SIN(S)*SIN(S-ALPHA)*SIN(S-BETA)*SIN(S-GAMMA)) CX(1,1) = 1./A CX(1,2) = -COSC/(A*SINC) CX(1,3) = B*C*(COSC*COSA-COSB)/(V*SINC) CX(2,1) = 0. CX(2,2) = 1./(B*SINC) CX(2,3) = A*C*(COSB*COSC-COSA)/(V*SINC) CX(3,1) = 0. CX(3,2) = 0. CX(3,3) = A*B*SINC/V RETURN END SUBROUTINE MATF2C (CELL, XC) DIMENSION CELL(6), XC(3,3) DIMENSION CELLT(6) EQUIVALENCE (A ,CELLT(1)), (B ,CELLT(2)) EQUIVALENCE (C ,CELLT(3)), (ALPH,CELLT(4)) EQUIVALENCE (BET ,CELLT(5)), (GAMM,CELLT(6)) CALL KERNAB (CELL, CELLT, 6) D2R = ATAN(1.0) / 45.0 ALPHA = ALPH * D2R BETA = BET * D2R GAMMA = GAMM * D2R COSA = COS(ALPHA) SINA = SIN(ALPHA) COSB = COS(BETA) SINB = SIN(BETA) COSC = COS(GAMMA) SINC = SIN(GAMMA) S = 0.5*(ALPHA+BETA+GAMMA) V = A*B*C *2. *SQRT(SIN(S)*SIN(S-ALPHA)*SIN(S-BETA)*SIN(S-GAMMA)) XC(1,1) = A XC(1,2) = B*COSC XC(1,3) = C*COSB XC(2,1) = 0. XC(2,2) = B*SINC XC(2,3) = -C*(COSB*COSC-COSA)/SINC XC(3,1) = 0. XC(3,2) = 0. XC(3,3) = V/(A*B*SINC) RETURN END SUBROUTINE VECAXB (A, B, V) DIMENSION A(3), B(3), V(3) T1 = A(2) * B(3) - A(3) * B(2) T2 = A(3) * B(1) - A(1) * B(3) V(3) = A(1) * B(2) - A(2) * B(1) V(1) = T1 V(2) = T2 RETURN END SUBROUTINE MATAXB (A, B, P) DIMENSION A(3,3), B(3,3), P(3,3) DO 112 K = 1, 3 DO 111 L = 1, 3 P(K,L) = A(K,1) * B(1,L) + A(K,2) * B(2,L) + A(K,3) * B(3,L) 111 CONTINUE 112 CONTINUE RETURN END SUBROUTINE MATAXI (IA, IB, IP) DIMENSION IA(3,3), IB(3,3), IP(3,3) DO 112 I = 1, 3 DO 111 J = 1, 3 IP(I,J) = IA(I,1) * IB(1,J) +IA(I,2) * IB(2,J) +IA(I,3) * IB(3,J) 111 CONTINUE 112 CONTINUE RETURN END SUBROUTINE MAT6XV (XC, X, C) DIMENSION XC(3,3), X(3), C(3) C(1) = X(1)*XC(1,1) + X(2)*XC(1,2) + X(3)*XC(1,3) C(2) = X(2)*XC(2,2) + X(3)*XC(2,3) C(3) = X(3)*XC(3,3) RETURN END SUBROUTINE MATXV3 (RR, A, B) DIMENSION RR(3,3), A(3), B(3) T1 = RR(1,1) * A(1) + RR(1,2) * A(2) + RR(1,3) * A(3) T2 = RR(2,1) * A(1) + RR(2,2) * A(2) + RR(2,3) * A(3) B(3) = RR(3,1) * A(1) + RR(3,2) * A(2) + RR(3,3) * A(3) B(1) = T1 B(2) = T2 RETURN END SUBROUTINE VXMATI (K, IR, L) DIMENSION K(3), IR(3,3), L(3) L1 = K(1) * IR(1,1) + K(2) * IR(2,1) + K(3) * IR(3,1) L2 = K(1) * IR(1,2) + K(2) * IR(2,2) + K(3) * IR(3,2) L(3) = K(1) * IR(1,3) + K(2) * IR(2,3) + K(3) * IR(3,3) L(1) = L1 L(2) = L2 RETURN END SUBROUTINE VMATV1 (A, R, B, Q) DIMENSION A(3), R(3,3), B(3) Q=A(1) * (R(1,1) * B(1) + R(1,2) * B(2) + R(1,3) * B(3)) + * A(2) * (R(2,1) * B(1) + R(2,2) * B(2) + R(2,3) * B(3)) + * A(3) * (R(3,1) * B(1) + R(3,2) * B(2) + R(3,3) * B(3)) RETURN END