page@swan.ulowell.edu (Bob Page) (11/03/88)
Submitted-by: strovink%galaxy-43@afit-ab.arpa (Mark A. Strovink)
Posting-number: Volume 2, Issue 41
Archive-name: applications/matlab/src.1
MATLAB stands for MATrix LABoratory. It is a FORTRAN package
developed by Argonne National Laboratories for in-house use. It
provides comprehensive vector and tensor operations in a package which
may be programmed, either through a macro language or through
execution of script files.
Matlab is reentrant and recursive. Functions supported include (but
not by any means limited to) sin, cos, tan, arcfunctions, upper
triangular, lower triangular, determinants, matrix multiplication,
identity, hilbert matrices, eigenvalues and eigenvectors, matrix roots
and products, inversion and so on and so forth.
The porter, Jim Locker, can be reached by phone at (513)-429-2771 from
8-5EST Mon-Fri. Jim says he is willing to "amigatize" matlab if there
is enough interest. So if you want pulldown menus, snazzy graphics,
better plotting, etc, write or call Jim. For $5 he will send the
complete package (all of this plus a manual). His address is: 4443 N.
Hyland Ave, Dayton OH 45424
Bob Walker, rbw%beta@lanl.gov, compiled the current matlab source with
the Absoft fortran compiler v2.3. The older compiler caused Matlab to
crash whenever you tried to write to a write-protected disk. There
are no known bugs in the current version.
[to re-create the distribution, join src-1 through src-7 to produce
matlab.for. Then join help-1 and help-2 to produce help.lis.
Finally, join doc-1 and doc-2 to produce matlab.doc. Executable and
SYM file will appear in comp.binaries.amiga. Docs will only appear in
the sources group, in parts 8-11 (they're too big to distribute
twice). ..Bob]
# This is a shell archive.
# Remove everything above and including the cut line.
# Then run the rest of the file through sh.
#----cut here-----cut here-----cut here-----cut here----#
#!/bin/sh
# shar: Shell Archiver
# Run the following text with /bin/sh to create:
# src-1
# This archive created: Wed Nov 2 16:20:05 1988
cat << \SHAR_EOF > src-1
C PROGRAM MAIN FOR Amiga
PROGRAM BIGMAT
CALL MATLAB(0)
STOP
END
SUBROUTINE CLAUSE
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER FOR(4),WHILE(4),IFF(4),ELSE(4),ENND(4),DO(4),THENN(4)
INTEGER SEMI,EQUAL,EOL,BLANK,R
INTEGER OP,COMMA,LESS,GREAT,NAME
LOGICAL EQID
DOUBLE PRECISION E1,E2
DATA SEMI/39/,EQUAL/46/,EOL/99/,BLANK/36/
DATA COMMA/48/,LESS/50/,GREAT/51/,NAME/1/
DATA FOR/15,24,27,36/,WHILE/32,17,18,21/,IFF/18,15,36,36/
DATA ELSE/14,21,28,14/,ENND/14,23,13,36/
DATA DO/13,24,36,36/,THENN/29,17,14,23/
R = -FIN-10
FIN = 0
IF (DDT .EQ. 1) WRITE(WTE,100) PT,RSTK(PT),R
100 FORMAT(1X,'CLAUSE',3I4)
IF (R.LT.1 .OR. R.GT.6) GO TO 01
GO TO (02,30,30,80,99,90),R
01 R = RSTK(PT)
GO TO (99,99,05,40,45,99,99,99,99,99,99,99,15,55,99,99,99),R
C
C FOR
C
02 CALL GETSYM
IF (SYM .NE. NAME) CALL ERROR(34)
IF (ERR .GT. 0) RETURN
PT = PT+2
CALL PUTID(IDS(1,PT),SYN)
CALL GETSYM
IF (SYM .NE. EQUAL) CALL ERROR(34)
IF (ERR .GT. 0) RETURN
CALL GETSYM
RSTK(PT) = 3
C *CALL* EXPR
RETURN
05 PSTK(PT-1) = 0
PSTK(PT) = LPT(4) - 1
IF (EQID(SYN,DO)) SYM = SEMI
IF (SYM .EQ. COMMA) SYM = SEMI
IF (SYM .NE. SEMI) CALL ERROR(34)
IF (ERR .GT. 0) RETURN
10 J = PSTK(PT-1)
LPT(4) = PSTK(PT)
SYM = SEMI
CHAR = BLANK
J = J+1
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
LJ = L+(J-1)*M
L2 = L + M*N
IF (M .NE. -3) GO TO 12
LJ = L+3
L2 = LJ
STKR(LJ) = STKR(L) + DFLOAT(J-1)*STKR(L+1)
STKI(LJ) = 0.0
IF (STKR(L+1).GT.0.0D0 .AND. STKR(LJ).GT.STKR(L+2)) GO TO 20
IF (STKR(L+1).LT.0.0D0 .AND. STKR(LJ).LT.STKR(L+2)) GO TO 20
M = 1
N = J
12 IF (J .GT. N) GO TO 20
IF (TOP+1 .GE. BOT) CALL ERROR(18)
IF (ERR .GT. 0) RETURN
TOP = TOP+1
LSTK(TOP) = L2
MSTK(TOP) = M
NSTK(TOP) = 1
ERR = L2+M - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
CALL WCOPY(M,STKR(LJ),STKI(LJ),1,STKR(L2),STKI(L2),1)
RHS = 0
CALL STACKP(IDS(1,PT))
IF (ERR .GT. 0) RETURN
PSTK(PT-1) = J
PSTK(PT) = LPT(4)
RSTK(PT) = 13
C *CALL* PARSE
RETURN
15 GO TO 10
20 MSTK(TOP) = 0
NSTK(TOP) = 0
RHS = 0
CALL STACKP(IDS(1,PT))
IF (ERR .GT. 0) RETURN
PT = PT-2
GO TO 80
C
C WHILE OR IF
C
30 PT = PT+1
CALL PUTID(IDS(1,PT),SYN)
PSTK(PT) = LPT(4)-1
35 LPT(4) = PSTK(PT)
CHAR = BLANK
CALL GETSYM
RSTK(PT) = 4
C *CALL* EXPR
RETURN
40 IF (SYM.NE.EQUAL .AND. SYM.NE.LESS .AND. SYM.NE.GREAT)
$ CALL ERROR(35)
IF (ERR .GT. 0) RETURN
OP = SYM
CALL GETSYM
IF (SYM.EQ.EQUAL .OR. SYM.EQ.GREAT) OP = OP + SYM
IF (OP .GT. GREAT) CALL GETSYM
PSTK(PT) = 256*PSTK(PT) + OP
RSTK(PT) = 5
C *CALL* EXPR
RETURN
45 OP = MOD(PSTK(PT),256)
PSTK(PT) = PSTK(PT)/256
L = LSTK(TOP-1)
E1 = STKR(L)
L = LSTK(TOP)
E2 = STKR(L)
TOP = TOP - 2
IF (EQID(SYN,DO) .OR. EQID(SYN,THENN)) SYM = SEMI
IF (SYM .EQ. COMMA) SYM = SEMI
IF (SYM .NE. SEMI) CALL ERROR(35)
IF (ERR .GT. 0) RETURN
IF (OP.EQ.EQUAL .AND. E1.EQ.E2) GO TO 50
IF (OP.EQ.LESS .AND. E1.LT.E2) GO TO 50
IF (OP.EQ.GREAT .AND. E1.GT.E2) GO TO 50
IF (OP.EQ.(LESS+EQUAL) .AND. E1.LE.E2) GO TO 50
IF (OP.EQ.(GREAT+EQUAL) .AND. E1.GE.E2) GO TO 50
IF (OP.EQ.(LESS+GREAT) .AND. E1.NE.E2) GO TO 50
PT = PT-1
GO TO 80
50 RSTK(PT) = 14
C *CALL* PARSE
RETURN
55 IF (EQID(IDS(1,PT),WHILE)) GO TO 35
PT = PT-1
IF (EQID(SYN,ELSE)) GO TO 80
RETURN
C
C SEARCH FOR MATCHING END OR ELSE
80 KOUNT = 0
CALL GETSYM
82 IF (SYM .EQ. EOL) RETURN
IF (SYM .NE. NAME) GO TO 83
IF (EQID(SYN,ENND) .AND. KOUNT.EQ.0) RETURN
IF (EQID(SYN,ELSE) .AND. KOUNT.EQ.0) RETURN
IF (EQID(SYN,ENND) .OR. EQID(SYN,ELSE))
$ KOUNT = KOUNT-1
IF (EQID(SYN,FOR) .OR. EQID(SYN,WHILE)
$ .OR. EQID(SYN,IFF)) KOUNT = KOUNT+1
83 CALL GETSYM
GO TO 82
C
C EXIT FROM LOOP
90 IF (DDT .EQ. 1) WRITE(WTE,190) (RSTK(I),I=1,PT)
190 FORMAT(1X,'EXIT ',10I4)
IF (RSTK(PT) .EQ. 14) PT = PT-1
IF (PT .LE. PTZ) RETURN
IF (RSTK(PT) .EQ. 14) PT = PT-1
IF (PT-1 .LE. PTZ) RETURN
IF (RSTK(PT) .EQ. 13) TOP = TOP-1
IF (RSTK(PT) .EQ. 13) PT = PT-2
GO TO 80
C
99 CALL ERROR(22)
IF (ERR .GT. 0) RETURN
RETURN
END
SUBROUTINE COMAND(ID)
INTEGER ID(4)
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER ALFA(52),ALFB(52),ALFL,CASE
INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /ALFS/ ALFA,ALFB,ALFL,CASE
COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER CMD(4,17),CMDL,A,D,E,Z,LRECL,CH,BLANK,NAME,DOT,H(4)
INTEGER SEMI,COMMA,EOL
DOUBLE PRECISION URAND
LOGICAL EQID
DATA CMDL/17/,A/10/,D/13/,E/14/,Z/35/,EOL/99/,SEMI/39/,COMMA/48/
DATA BLANK/36/,NAME/1/,DOT/47/
C
C CLEAR ELSE END EXIT
C FOR HELP IF LONG
C RETUR SEMI
C SHORT WHAT WHILE
C WHO WHY LALA FOO
DATA CMD/
$ 12,21,14,10, 14,21,28,14, 14,23,13,36, 14,33,18,29,
$ 15,24,27,36, 17,14,21,25, 18,15,36,36, 21,24,23,16,
$ 27,14,29,30, 28,14,22,18,
$ 28,17,24,27, 32,17,10,29, 32,17,18,21,
$ 32,17,24,36, 32,17,34,36, 21,10,21,10, 15,30,12,20/
C
DATA LRECL/80/
101 FORMAT(80A1)
102 FORMAT(1X,80A1)
C
IF (DDT .EQ. 1) WRITE(WTE,100)
100 FORMAT(1X,'COMAND')
FUN = 0
DO 10 K = 1, CMDL
IF (EQID(ID,CMD(1,K))) GO TO 20
10 CONTINUE
FIN = 0
RETURN
C
20 IF (CHAR.EQ.COMMA .OR. CHAR.EQ.SEMI .OR. CHAR.EQ.EOL) GO TO 22
IF (CHAR.LE.Z .OR. K.EQ.6) GO TO 22
CALL ERROR(16)
RETURN
C
22 FIN = 1
GO TO (25,36,38,40,30,80,34,52,44,55,50,65,32,60,70,46,48),K
C
C CLEAR
25 IF (CHAR.GE.A .AND. CHAR.LE.Z) GO TO 26
BOT = LSIZE-3
GO TO 98
26 CALL GETSYM
TOP = TOP+1
MSTK(TOP) = 0
NSTK(TOP) = 0
RHS = 0
CALL STACKP(SYN)
IF (ERR .GT. 0) RETURN
FIN = 1
GO TO 98
C
C FOR, WHILE, IF, ELSE, END
30 FIN = -11
GO TO 99
32 FIN = -12
GO TO 99
34 FIN = -13
GO TO 99
36 FIN = -14
GO TO 99
38 FIN = -15
GO TO 99
C
C EXIT
40 IF (PT .GT. PTZ) FIN = -16
IF (PT .GT. PTZ) GO TO 98
K = IDINT(STKR(VSIZE-2))
WRITE(WTE,140) K
IF (WIO .NE. 0) WRITE(WIO,140) K
140 FORMAT(/1X,'total flops ',I9//1X,'ADIOS'/)
FUN = 99
GO TO 98
C
C RETURN
44 K = LPT(1) - 7
IF (K .LE. 0) FUN = 99
IF (K .LE. 0) GO TO 98
CALL FILES(-1*RIO,BUF)
LPT(1) = LIN(K+1)
LPT(4) = LIN(K+2)
LPT(6) = LIN(K+3)
PTZ = LIN(K+4)
RIO = LIN(K+5)
LCT(4) = LIN(K+6)
CHAR = BLANK
SYM = COMMA
GO TO 99
C
C LALA
46 WRITE(WTE,146)
146 FORMAT(1X,'QUIT SINGING AND GET BACK TO WORK.')
GO TO 98
C
C FOO
48 WRITE(WTE,148)
148 FORMAT(1X,'YOUR PLACE OR MINE')
GO TO 98
C
C SHORT, LONG
50 FMT = 1
GO TO 54
52 FMT = 2
54 IF (CHAR.EQ.E .OR. CHAR.EQ.D) FMT = FMT+2
IF (CHAR .EQ. Z) FMT = 5
IF (CHAR.EQ.E .OR. CHAR.EQ.D .OR. CHAR.EQ.Z) CALL GETSYM
GO TO 98
C
C SEMI
55 LCT(3) = 1 - LCT(3)
GO TO 98
C
C WHO
60 WRITE(WTE,160)
IF (WIO .NE. 0) WRITE(WIO,160)
160 FORMAT(1X,'Your current variables are...')
CALL PRNTID(IDSTK(1,BOT),LSIZE-BOT+1)
L = VSIZE-LSTK(BOT)+1
WRITE(WTE,161) L,VSIZE
IF (WIO .NE. 0) WRITE(WIO,161) L,VSIZE
161 FORMAT(1X,'using ',I7,' out of ',I7,' elements.')
GO TO 98
C
C WHAT
65 WRITE(WTE,165)
165 FORMAT(1X,'The functions and commands are...')
H(1) = 0
CALL FUNS(H)
CALL PRNTID(CMD,CMDL-2)
GO TO 98
C
C WHY
70 K = IDINT(9.0D0*URAND(RAN(1))+1.0D0)
GO TO (71,72,73,74,75,76,77,78,79),K
71 WRITE(WTE,171)
171 FORMAT(1X,'WHAT?')
GO TO 98
72 WRITE(WTE,172)
172 FORMAT(1X,'R.T.F.M.')
GO TO 98
73 WRITE(WTE,173)
173 FORMAT(1X,'HOW THE HELL SHOULD I KNOW?')
GO TO 98
74 WRITE(WTE,174)
174 FORMAT(1X,'PETE MADE ME DO IT.')
GO TO 98
75 WRITE(WTE,175)
175 FORMAT(1X,'INSUFFICIENT DATA TO ANSWER.')
GO TO 98
76 WRITE(WTE,176)
176 FORMAT(1X,'IT FEELS GOOD.')
GO TO 98
77 WRITE(WTE,177)
177 FORMAT(1X,'WHY NOT?')
GO TO 98
78 WRITE(WTE,178)
178 FORMAT(1X,'/--ERROR'/1X,'STUPID QUESTION.')
GO TO 98
79 WRITE(WTE,179)
179 FORMAT(1X,'SYSTEM ERROR, RETRY')
GO TO 98
C
C HELP
80 IF (CHAR .NE. EOL) GO TO 81
WRITE(WTE,180)
IF (WIO .NE. 0) WRITE(WIO,180)
180 FORMAT(1X,'Type HELP followed by ...'
$ /1X,'INTRO (To get started)'
$ /1X,'NEWS (recent revisions)')
H(1) = 0
CALL FUNS(H)
CALL PRNTID(CMD,CMDL-2)
J = BLANK+2
WRITE(WTE,181)
IF (WIO .NE. 0) WRITE(WIO,181)
181 FORMAT(1X,'ANS EDIT FILE FUN MACRO')
WRITE(WTE,182) (ALFA(I),I=J,ALFL)
IF (WIO .NE. 0) WRITE(WIO,182) (ALFA(I),I=J,ALFL)
182 FORMAT(1X,17(A1,1X)/)
GO TO 98
C
81 CALL GETSYM
IF (SYM .EQ. NAME) GO TO 82
IF (SYM .EQ. 0) SYM = DOT
H(1) = ALFA(SYM+1)
H(2) = ALFA(BLANK+1)
H(3) = ALFA(BLANK+1)
H(4) = ALFA(BLANK+1)
GO TO 84
82 DO 83 I = 1, 4
CH = SYN(I)
H(I) = ALFA(CH+1)
83 CONTINUE
84 IF(HIO .NE. 0) THEN
READ(HIO,101,END=89) (BUF(I),I=1,LRECL)
CDC.. IF (EOF(HIO).NE.0) GO TO 89
DO 85 I = 1, 4
IF (H(I) .NE. BUF(I)) GO TO 84
85 CONTINUE
WRITE(WTE,102)
IF (WIO .NE. 0) WRITE(WIO,102)
86 K = LRECL + 1
87 K = K - 1
IF (BUF(K) .EQ. ALFA(BLANK+1)) GO TO 87
WRITE(WTE,102) (BUF(I),I=1,K)
IF (WIO .NE. 0) WRITE(WIO,102) (BUF(I),I=1,K)
READ(HIO,101) (BUF(I),I=1,LRECL)
IF (BUF(1) .EQ. ALFA(BLANK+1)) GO TO 86
CALL FILES(-HIO,BUF)
GO TO 98
ENDIF
C
89 WRITE(WTE,189) (H(I),I=1,4)
189 FORMAT(1X,'SORRY, NO HELP ON ',4A1)
CALL FILES(-HIO,BUF)
GO TO 98
C
98 CALL GETSYM
99 RETURN
END
SUBROUTINE EDIT(BUF,N)
INTEGER BUF(N)
C
C CALLED AFTER INPUT OF A SINGLE BACKSLASH
C BUF CONTAINS PREVIOUS INPUT LINE, ONE CHAR PER WORD
C ENTER LOCAL EDITOR IF AVAILABLE
C OTHERWISE JUST
RETURN
END
SUBROUTINE ERROR(N)
INTEGER N
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ
INTEGER ALFA(52),ALFB(52),ALFL,CASE
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ
COMMON /ALFS/ ALFA,ALFB,ALFL,CASE
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER ERRMSG(8),BLH,BEL
DATA ERRMSG /1H/,1H-,1H-,1HE,1HR,1HR,1HO,1HR/,BLH/1H /,BEL/1H /
C SET BEL TO CTRL-G IF POSSIBLE
C
K = LPT(2) - LPT(1)
IF (K .LT. 1) K = 1
LUNIT = WTE
98 WRITE(LUNIT,100) (BLH,I=1,K),(ERRMSG(I),I=1,8),BEL
100 FORMAT(1X,80A1)
GO TO (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,28,29,30,31,32,33,34,35,36,37,38,39,40),N
C
1 WRITE(LUNIT,101)
101 FORMAT(1X,'IMPROPER MULTIPLE ASSIGNMENT')
GO TO 99
2 WRITE(LUNIT,102)
102 FORMAT(1X,'IMPROPER FACTOR')
GO TO 99
3 WRITE(LUNIT,103)
103 FORMAT(1X,'EXPECT RIGHT PARENTHESIS')
GO TO 99
4 DO 94 I = 1, 4
K = IDS(I,PT+1)
BUF(I) = ALFA(K+1)
94 CONTINUE
WRITE(LUNIT,104) (BUF(I),I=1,4)
104 FORMAT(1X,'UNDEFINED VARIABLE: ',4A1)
GO TO 99
5 WRITE(LUNIT,105)
105 FORMAT(1X,'COLUMN LENGTHS DO NOT MATCH')
GO TO 99
6 WRITE(LUNIT,106)
106 FORMAT(1X,'ROW LENGTHS DO NOT MATCH')
GO TO 99
7 WRITE(LUNIT,107)
107 FORMAT(1X,'TEXT TOO LONG')
GO TO 99
8 WRITE(LUNIT,108)
108 FORMAT(1X,'INCOMPATIBLE FOR ADDITION')
GO TO 99
9 WRITE(LUNIT,109)
109 FORMAT(1X,'INCOMPATIBLE FOR SUBTRACTION')
GO TO 99
10 WRITE(LUNIT,110)
110 FORMAT(1X,'INCOMPATIBLE FOR MULTIPLICATION')
GO TO 99
11 WRITE(LUNIT,111)
111 FORMAT(1X,'INCOMPATIBLE FOR RIGHT DIVISION')
GO TO 99
12 WRITE(LUNIT,112)
112 FORMAT(1X,'INCOMPATIBLE FOR LEFT DIVISION')
GO TO 99
13 WRITE(LUNIT,113)
113 FORMAT(1X,'IMPROPER ASSIGNMENT TO PERMANENT VARIABLE')
GO TO 99
14 WRITE(LUNIT,114)
114 FORMAT(1X,'EYE-DENTITY UNDEFINED BY CONTEXT')
GO TO 99
15 WRITE(LUNIT,115)
115 FORMAT(1X,'IMPROPER ASSIGNMENT TO SUBMATRIX')
GO TO 99
16 WRITE(LUNIT,116)
116 FORMAT(1X,'IMPROPER COMMAND')
GO TO 99
17 LB = VSIZE - LSTK(BOT) + 1
LT = ERR + LSTK(BOT)
WRITE(LUNIT,117) LB,LT,VSIZE
117 FORMAT(1X,'TOO MUCH MEMORY REQUIRED'
$ /1X,' ',I7,' VARIABLES,',I7,' TEMPORARIES,',I7,' AVAILABLE.')
GO TO 99
18 WRITE(LUNIT,118)
118 FORMAT(1X,'TOO MANY NAMES')
GO TO 99
19 WRITE(LUNIT,119)
119 FORMAT(1X,'MATRIX IS SINGULAR TO WORKING PRECISION')
GO TO 99
20 WRITE(LUNIT,120)
120 FORMAT(1X,'MATRIX MUST BE SQUARE')
GO TO 99
21 WRITE(LUNIT,121)
121 FORMAT(1X,'SUBSCRIPT OUT OF RANGE')
GO TO 99
22 WRITE(LUNIT,122) (RSTK(I),I=1,PT)
122 FORMAT(1X,'RECURSION DIFFICULTIES',10I4)
GO TO 99
23 WRITE(LUNIT,123)
123 FORMAT(1X,'ONLY 1, 2 OR INF NORM OF MATRIX')
GO TO 99
24 WRITE(LUNIT,124)
124 FORMAT(1X,'NO CONVERGENCE')
GO TO 99
25 WRITE(LUNIT,125)
125 FORMAT(1X,'CAN NOT USE FUNCTION NAME AS VARIABLE')
GO TO 99
26 WRITE(LUNIT,126)
126 FORMAT(1X,'TOO COMPLICATED (STACK OVERFLOW)')
GO TO 99
27 WRITE(LUNIT,127)
127 FORMAT(1X,'DIVISION BY ZERO IS A NO-NO')
GO TO 99
28 WRITE(LUNIT,128)
128 FORMAT(1X,'EMPTY MACRO')
GO TO 99
29 WRITE(LUNIT,129)
129 FORMAT(1X,'NOT POSITIVE DEFINITE')
GO TO 99
30 WRITE(LUNIT,130)
130 FORMAT(1X,'IMPROPER EXPONENT')
GO TO 99
31 WRITE(LUNIT,131)
131 FORMAT(1X,'IMPROPER STRING')
GO TO 99
32 WRITE(LUNIT,132)
132 FORMAT(1X,'SINGULARITY OF LOG OR ATAN')
GO TO 99
33 WRITE(LUNIT,133)
133 FORMAT(1X,'TOO MANY COLONS')
GO TO 99
34 WRITE(LUNIT,134)
134 FORMAT(1X,'IMPROPER FOR CLAUSE')
GO TO 99
35 WRITE(LUNIT,135)
135 FORMAT(1X,'IMPROPER WHILE OR IF CLAUSE')
GO TO 99
36 WRITE(LUNIT,136)
136 FORMAT(1X,'ARGUMENT OUT OF RANGE')
GO TO 99
37 WRITE(LUNIT,137)
137 FORMAT(1X,'IMPROPER MACRO')
GO TO 99
38 WRITE(LUNIT,138)
138 FORMAT(1X,'IMPROPER FILE NAME')
GO TO 99
39 WRITE(LUNIT,139)
139 FORMAT(1X,'INCORRECT NUMBER OF ARGUMENTS')
GO TO 99
40 WRITE(LUNIT,140)
140 FORMAT(1X,'EXPECT STATEMENT TERMINATOR')
GO TO 99
C
99 ERR = N
IF (LUNIT.EQ.WIO .OR. WIO.EQ.0) RETURN
LUNIT = WIO
GO TO 98
END
SUBROUTINE EXPR
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER OP,R,BLANK,SIGN,PLUS,MINUS,NAME,COLON,EYE(4)
DATA COLON/40/,BLANK/36/,PLUS/41/,MINUS/42/,NAME/1/
DATA EYE/14,34,14,36/
IF (DDT .EQ. 1) WRITE(WTE,100) PT,RSTK(PT)
100 FORMAT(1X,'EXPR ',2I4)
R = RSTK(PT)
GO TO (01,01,01,01,01,05,25,99,99,01,01,99,99,99,99,99,99,01,01,
$ 01),R
01 IF (SYM .EQ. COLON) CALL PUTID(SYN,EYE)
IF (SYM .EQ. COLON) SYM = NAME
KOUNT = 1
02 SIGN = PLUS
IF (SYM .EQ. MINUS) SIGN = MINUS
IF (SYM.EQ.PLUS .OR. SYM.EQ.MINUS) CALL GETSYM
PT = PT+1
IF (PT .GT. PSIZE-1) CALL ERROR(26)
IF (ERR .GT. 0) RETURN
PSTK(PT) = SIGN + 256*KOUNT
RSTK(PT) = 6
C *CALL* TERM
RETURN
05 SIGN = MOD(PSTK(PT),256)
KOUNT = PSTK(PT)/256
PT = PT-1
IF (SIGN .EQ. MINUS) CALL STACK1(MINUS)
IF (ERR .GT. 0) RETURN
10 IF (SYM.EQ.PLUS .OR. SYM.EQ.MINUS) GO TO 20
GO TO 50
20 IF (RSTK(PT) .NE. 10) GO TO 21
C BLANK IS DELIMITER INSIDE ANGLE BRACKETS
LS = LPT(3) - 2
IF (LIN(LS) .EQ. BLANK) GO TO 50
21 OP = SYM
CALL GETSYM
PT = PT+1
PSTK(PT) = OP + 256*KOUNT
RSTK(PT) = 7
C *CALL* TERM
RETURN
25 OP = MOD(PSTK(PT),256)
KOUNT = PSTK(PT)/256
PT = PT-1
CALL STACK2(OP)
IF (ERR .GT. 0) RETURN
GO TO 10
50 IF (SYM .NE. COLON) GO TO 60
CALL GETSYM
KOUNT = KOUNT+1
GO TO 02
60 IF (KOUNT .GT. 3) CALL ERROR(33)
IF (ERR .GT. 0) RETURN
RHS = KOUNT
IF (KOUNT .GT. 1) CALL STACK2(COLON)
IF (ERR .GT. 0) RETURN
RETURN
99 CALL ERROR(22)
IF (ERR .GT. 0) RETURN
RETURN
END
SUBROUTINE FACTOR
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER SEMI,EOL,BLANK,R,ID(4),EXCNT,LPAREN,RPAREN
INTEGER STAR,DSTAR,COMMA,LESS,GREAT,QUOTE,NUM,NAME,ALFL
DATA DSTAR/54/,SEMI/39/,EOL/99/,BLANK/36/
DATA STAR/43/,COMMA/48/,LPAREN/37/,RPAREN/38/
DATA LESS/50/,GREAT/51/,QUOTE/49/,NUM/0/,NAME/1/,ALFL/52/
IF (DDT .EQ. 1) WRITE(WTE,100) PT,RSTK(PT),SYM
100 FORMAT(1X,'FACTOR',3I4)
R = RSTK(PT)
GO TO (99,99,99,99,99,99,99,01,01,25,45,65,99,99,99,55,75,32,37),R
01 IF (SYM.EQ.NUM .OR. SYM.EQ.QUOTE .OR. SYM.EQ.LESS) GO TO 10
IF (SYM .EQ. GREAT) GO TO 30
EXCNT = 0
IF (SYM .EQ. NAME) GO TO 40
ID(1) = BLANK
IF (SYM .EQ. LPAREN) GO TO 42
CALL ERROR(2)
IF (ERR .GT. 0) RETURN
C
C PUT SOMETHING ON THE STACK
10 L = 1
IF (TOP .GT. 0) L = LSTK(TOP) + MSTK(TOP)*NSTK(TOP)
IF (TOP+1 .GE. BOT) CALL ERROR(18)
IF (ERR .GT. 0) RETURN
TOP = TOP+1
LSTK(TOP) = L
IF (SYM .EQ. QUOTE) GO TO 15
IF (SYM .EQ. LESS) GO TO 20
C
C SINGLE NUMBER, GETSYM STORED IT IN STKI
MSTK(TOP) = 1
NSTK(TOP) = 1
STKR(L) = STKI(VSIZE)
STKI(L) = 0.0D0
CALL GETSYM
GO TO 60
C
C STRING
15 N = 0
LPT(4) = LPT(3)
CALL GETCH
16 IF (CHAR .EQ. QUOTE) GO TO 18
17 LN = L+N
IF (CHAR .EQ. EOL) CALL ERROR(31)
IF (ERR .GT. 0) RETURN
STKR(LN) = DFLOAT(CHAR)
STKI(LN) = 0.0D0
N = N+1
CALL GETCH
GO TO 16
18 CALL GETCH
IF (CHAR .EQ. QUOTE) GO TO 17
IF (N .LE. 0) CALL ERROR(31)
IF (ERR .GT. 0) RETURN
MSTK(TOP) = 1
NSTK(TOP) = N
CALL GETSYM
GO TO 60
C
C EXPLICIT MATRIX
20 MSTK(TOP) = 0
NSTK(TOP) = 0
21 TOP = TOP + 1
LSTK(TOP) = LSTK(TOP-1) + MSTK(TOP-1)*NSTK(TOP-1)
MSTK(TOP) = 0
NSTK(TOP) = 0
CALL GETSYM
22 IF (SYM.EQ.SEMI .OR. SYM.EQ.GREAT .OR. SYM.EQ.EOL) GO TO 27
IF (SYM .EQ. COMMA) CALL GETSYM
PT = PT+1
RSTK(PT) = 10
C *CALL* EXPR
RETURN
25 PT = PT-1
TOP = TOP - 1
IF (MSTK(TOP) .EQ. 0) MSTK(TOP) = MSTK(TOP+1)
IF (MSTK(TOP) .NE. MSTK(TOP+1)) CALL ERROR(5)
IF (ERR .GT. 0) RETURN
NSTK(TOP) = NSTK(TOP) + NSTK(TOP+1)
GO TO 22
27 IF (SYM.EQ.SEMI .AND. CHAR.EQ.EOL) CALL GETSYM
CALL STACK1(QUOTE)
IF (ERR .GT. 0) RETURN
TOP = TOP - 1
IF (MSTK(TOP) .EQ. 0) MSTK(TOP) = MSTK(TOP+1)
IF (MSTK(TOP).NE.MSTK(TOP+1) .AND. MSTK(TOP+1).GT.0) CALL ERROR(6)
IF (ERR .GT. 0) RETURN
NSTK(TOP) = NSTK(TOP) + NSTK(TOP+1)
IF (SYM .EQ. EOL) CALL GETLIN
IF (SYM .NE. GREAT) GO TO 21
CALL STACK1(QUOTE)
IF (ERR .GT. 0) RETURN
CALL GETSYM
GO TO 60
C
C MACRO STRING
30 CALL GETSYM
IF (SYM.EQ.LESS .AND. CHAR.EQ.EOL) CALL ERROR(28)
IF (ERR .GT. 0) RETURN
PT = PT+1
RSTK(PT) = 18
C *CALL* EXPR
RETURN
32 PT = PT-1
IF (SYM.NE.LESS .AND. SYM.NE.EOL) CALL ERROR(37)
IF (ERR .GT. 0) RETURN
IF (SYM .EQ. LESS) CALL GETSYM
K = LPT(6)
LIN(K+1) = LPT(1)
LIN(K+2) = LPT(2)
LIN(K+3) = LPT(6)
LPT(1) = K + 4
C TRANSFER STACK TO INPUT LINE
K = LPT(1)
L = LSTK(TOP)
N = MSTK(TOP)*NSTK(TOP)
DO 34 J = 1, N
LS = L + J-1
LIN(K) = IDINT(STKR(LS))
IF (LIN(K).LT.0 .OR. LIN(K).GE.ALFL) CALL ERROR(37)
IF (ERR .GT. 0) RETURN
IF (K.LT.1024) K = K+1
IF (K.EQ.1024) WRITE(WTE,33) K
33 FORMAT(1X,'INPUT BUFFER LIMIT IS ',I4,' CHARACTERS.')
34 CONTINUE
TOP = TOP-1
LIN(K) = EOL
LPT(6) = K
LPT(4) = LPT(1)
LPT(3) = 0
LPT(2) = 0
LCT(1) = 0
CHAR = BLANK
CALL GETSYM
PT = PT+1
RSTK(PT) = 19
C *CALL* EXPR
RETURN
37 PT = PT-1
K = LPT(1) - 4
LPT(1) = LIN(K+1)
LPT(4) = LIN(K+2)
LPT(6) = LIN(K+3)
CHAR = BLANK
CALL GETSYM
GO TO 60
C
C FUNCTION OR MATRIX ELEMENT
40 CALL PUTID(ID,SYN)
CALL GETSYM
IF (SYM .EQ. LPAREN) GO TO 42
RHS = 0
CALL FUNS(ID)
IF (FIN .NE. 0) CALL ERROR(25)
IF (ERR .GT. 0) RETURN
CALL STACKG(ID)
IF (ERR .GT. 0) RETURN
IF (FIN .EQ. 7) GO TO 50
IF (FIN .EQ. 0) CALL PUTID(IDS(1,PT+1),ID)
IF (FIN .EQ. 0) CALL ERROR(4)
IF (ERR .GT. 0) RETURN
GO TO 60
C
42 CALL GETSYM
EXCNT = EXCNT+1
PT = PT+1
PSTK(PT) = EXCNT
CALL PUTID(IDS(1,PT),ID)
RSTK(PT) = 11
C *CALL* EXPR
RETURN
45 CALL PUTID(ID,IDS(1,PT))
EXCNT = PSTK(PT)
PT = PT-1
IF (SYM .EQ. COMMA) GO TO 42
IF (SYM .NE. RPAREN) CALL ERROR(3)
IF (ERR .GT. 0) RETURN
IF (SYM .EQ. RPAREN) CALL GETSYM
IF (ID(1) .EQ. BLANK) GO TO 60
RHS = EXCNT
CALL STACKG(ID)
IF (ERR .GT. 0) RETURN
IF (FIN .EQ. 0) CALL FUNS(ID)
IF (FIN .EQ. 0) CALL ERROR(4)
IF (ERR .GT. 0) RETURN
C
C EVALUATE MATRIX FUNCTION
50 PT = PT+1
RSTK(PT) = 16
C *CALL* MATFN
RETURN
55 PT = PT-1
GO TO 60
C
C CHECK FOR QUOTE (TRANSPOSE) AND ** (POWER)
60 IF (SYM .NE. QUOTE) GO TO 62
I = LPT(3) - 2
IF (LIN(I) .EQ. BLANK) GO TO 90
CALL STACK1(QUOTE)
IF (ERR .GT. 0) RETURN
CALL GETSYM
62 IF (SYM.NE.STAR .OR. CHAR.NE.STAR) GO TO 90
CALL GETSYM
CALL GETSYM
PT = PT+1
RSTK(PT) = 12
C *CALL* FACTOR
GO TO 01
65 PT = PT-1
CALL STACK2(DSTAR)
IF (ERR .GT. 0) RETURN
IF (FUN .NE. 2) GO TO 90
C MATRIX POWER, USE EIGENVECTORS
PT = PT+1
RSTK(PT) = 17
C *CALL* MATFN
RETURN
75 PT = PT-1
90 RETURN
99 CALL ERROR(22)
IF (ERR .GT. 0) RETURN
RETURN
END
SUBROUTINE FILES(LUNIT,NAME)
INTEGER LUNIT
C
C AMIGA SPECIFIC ROUTINE TO ALLOCATE FILES
C LUNIT = LOGICAL UNIT NUMBER
C NAME = FILE NAME, 1 CHARACTER PER WORD
C
character*1024 NAME
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
C
C Amiga dependent stuff to squeeze the NAME from one char per word to one
C per byte
C
character*1024 NAME2
integer*1 strip(4,256),strip2(32)
character*32 NAME3
equivalence (NAME2,strip),(NAME3,strip2)
C
FE=0
C
C ERROR CATCHER
IF (LUNIT .EQ. 0) RETURN
C
C PRINTER
if (LUNIT .eq. 6) return
C
C TERMINAL I/O
if (LUNIT .eq. 9) return
C
C HELP FILE
if (LUNIT .eq. 11) then
OPEN(11,FILE='HELP.LIS',STATUS='OLD',ERR=14)
write(9,09)
09 format(/1X,'HELP is available')
return
end if
if (LUNIT .eq. -11 .AND. HIO .NE. 0) then
rewind (11,ERR=99)
return
end if
if (LUNIT .lt. 0) then
close(unit=-LUNIT,ERR=99)
return
end if
10 continue
C
C ALL OTHER FILES
C
NAME2=NAME
do 37 j=1,32
37 strip2(j)=strip(1,j)
OPEN(UNIT=LUNIT,FILE=NAME3,STATUS='UNKNOWN',ERR=98)
RETURN
14 WRITE(9,15)
C
C HELP FILE NOT FOUND
C
15 FORMAT(1X,'HELP IS NOT AVAILABLE')
HIO = 0
RETURN
C
C GENERAL FILE OPEN FAILURE
C
98 WRITE(9,16)
16 FORMAT(1X,'OPEN FILE FAILED')
FE=1
C IF THIS WAS A DIARY FILE (OUTPUT), SET ITS FILE HANDLE TO 0
IF(LUNIT .EQ. 8) THEN
WIO=0
C
C OTHERWISE, SET THE I/O TO TERMINAL I/O
C
ELSE
RIO=RTE
ENDIF
RETURN
99 CONTINUE
RETURN
END
DOUBLE PRECISION FUNCTION FLOP(X)
DOUBLE PRECISION X
C SYSTEM DEPENDENT FUNCTION
C COUNT AND POSSIBLY CHOP EACH FLOATING POINT OPERATION
C FLP(1) IS FLOP COUNTER
C FLP(2) IS NUMBER OF PLACES TO BE CHOPPED
C
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
C
DOUBLE PRECISION MASK(14),XX,MM
real mas(2,14)
LOGICAL LX(2),LM(2)
EQUIVALENCE (LX(1),XX),(LM(1),MM)
equivalence (MASK(1),mas(1))
data mas/
$ Z'ffffffff',Z'fff0ffff',
$ Z'ffffffff',Z'ff00ffff',
$ Z'ffffffff',Z'f000ffff',
$ Z'ffffffff',Z'0000ffff',
$ Z'ffffffff',Z'0000fff0',
$ Z'ffffffff',Z'0000ff00',
$ Z'ffffffff',Z'0000f000',
$ Z'ffffffff',Z'00000000',
$ Z'fff0ffff',Z'00000000',
$ Z'ff00ffff',Z'00000000',
$ Z'f000ffff',Z'00000000',
$ Z'0000ffff',Z'00000000',
$ Z'0000fff0',Z'00000000',
$ Z'0000ff80',Z'00000000'/
C
FLP(1) = FLP(1) + 1
K = FLP(2)
FLOP = X
IF (K .LE. 0) RETURN
FLOP = 0.0D0
IF (K .GE. 15) RETURN
XX = X
MM = MASK(K)
LX(1) = LX(1) .AND. LM(1)
LX(2) = LX(2) .AND. LM(2)
FLOP = XX
RETURN
END
SUBROUTINE FORMZ(LUNIT,X,Y)
DOUBLE PRECISION X,Y
C
C SYSTEM DEPENDENT ROUTINE TO PRINT WITH Z FORMAT
C
IF (Y .NE. 0.0D0) WRITE(LUNIT,10) X,Y
IF (Y .EQ. 0.0D0) WRITE(LUNIT,10) X
10 FORMAT(2Z18)
RETURN
END
SUBROUTINE FUNS(ID)
INTEGER ID(4)
C
C SCAN FUNCTION LIST
C
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
LOGICAL EQID
INTEGER FUNL,FUNN(4,57),FUNP(57)
DATA FUNL/57/
C
C 1 ABS ATAN BASE CHAR
C 2 CHOL CHOP COND CONJ
C 3 COS DET DIAG DIAR
C 4 DISP EIG EPS EXEC
C 5 EXP EYE FLOP HESS
C 6 HILB IMAG INV KRON
C 7 LINE LOAD LOG LU
C 8 MAGIC NORM ONES ORTH
C 9 PINV PLOT POLY PRINT
C $ PROD QR RAND RANK
C 1 RAT RCOND REAL ROOT
C 2 ROUND RREF SAVE SCHUR
C 3 SIN SIZE SQRT SUM
C 4 SVD TRIL TRIU USER
C 5 DEBUG
C
DATA FUNN/
1 10,11,28,36, 10,29,10,23, 11,10,28,14, 12,17,10,27,
2 12,17,24,21, 12,17,24,25, 12,24,23,13, 12,24,23,19,
3 12,24,28,36, 13,14,29,36, 13,18,10,16, 13,18,10,27,
4 13,18,28,25, 14,18,16,36, 14,25,28,36, 14,33,14,12,
5 14,33,25,36, 14,34,14,36, 15,21,24,25, 17,14,28,28,
6 17,18,21,11, 18,22,10,16, 18,23,31,36, 20,27,24,23,
7 21,18,23,14, 21,24,10,13, 21,24,16,36, 21,30,36,36,
8 22,10,16,18, 23,24,27,22, 24,23,14,28, 24,27,29,17,
9 25,18,23,31, 25,21,24,29, 25,24,21,34, 25,27,18,23,
$ 25,27,24,13, 26,27,36,36, 27,10,23,13, 27,10,23,20,
1 27,10,29,36, 27,12,24,23, 27,14,10,21, 27,24,24,29,
2 27,24,30,23, 27,27,14,15, 28,10,31,14, 28,12,17,30,
3 28,18,23,36, 28,18,35,14, 28,26,27,29, 28,30,22,36,
4 28,31,13,36, 29,27,18,21, 29,27,18,30, 30,28,14,27,
5 13,14,11,30/
C
DATA FUNP/
1 221,203,507,509, 106,609,303,225, 202,102,602,505,
4 506,211,000,501, 204,606,000,213, 105,224,101,611,
7 508,503,206,104, 601,304,608,402, 302,510,214,504,
$ 604,401,607,305, 511,103,223,215, 222,107,502,212,
3 201,610,205,603, 301,614,615,605, 512/
C
IF (ID(1).EQ.0) CALL PRNTID(FUNN,FUNL-1)
IF (ID(1).EQ.0) RETURN
C
DO 10 K = 1, FUNL
IF (EQID(ID,FUNN(1,K))) GO TO 20
10 CONTINUE
FIN = 0
RETURN
C
20 FIN = MOD(FUNP(K),100)
FUN = FUNP(K)/100
IF (RHS.EQ.0 .AND. FUNP(K).EQ.606) FIN = 0
IF (RHS.EQ.0 .AND. FUNP(K).EQ.607) FIN = 0
RETURN
END
SUBROUTINE GETCH
C GET NEXT CHARACTER
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER EOL
DATA EOL/99/
L = LPT(4)
CHAR = LIN(L)
IF (CHAR .NE. EOL) LPT(4) = L + 1
RETURN
END
SUBROUTINE GETLIN
C GET A NEW LINE
INTEGER ALFA(52),ALFB(52),ALFL,CASE
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /ALFS/ ALFA,ALFB,ALFL,CASE
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER LRECL,EOL,SLASH,BSLASH,DOT,BLANK,RETU(4)
DATA EOL/99/,DOT/47/,BLANK/36/,RETU/27,14,29,30/
DATA SLASH/44/,BSLASH/45/,LRECL/80/
C
10 L = LPT(1)
11 DO 12 J = 1, LRECL
BUF(J) = ALFA(BLANK+1)
12 CONTINUE
READ(RIO,101,END=50,ERR=15) (BUF(J),J=1,LRECL)
CDC.. IF (EOF(RIO).NE.0) GO TO 50
101 FORMAT(80A1)
N = LRECL+1
15 N = N-1
IF (BUF(N) .EQ. ALFA(BLANK+1)) GO TO 15
IF (MOD(LCT(4),2) .EQ. 1) WRITE(WTE,102) (BUF(J),J=1,N)
IF (WIO .NE. 0) WRITE(WIO,102) (BUF(J),J=1,N)
102 FORMAT(1X,80A1)
C
DO 40 J = 1, N
DO 20 K = 1, ALFL
IF (BUF(J).EQ.ALFA(K) .OR. BUF(J).EQ.ALFB(K)) GO TO 30
20 CONTINUE
K = EOL+1
CALL XCHAR(BUF(J),K)
IF (K .GT. EOL) GO TO 10
IF (K .EQ. EOL) GO TO 45
IF (K .EQ. -1) L = L-1
IF (K .LE. 0) GO TO 40
C
30 K = K-1
IF (K.EQ.SLASH .AND. BUF(J+1).EQ.BUF(J)) GO TO 45
IF (K.EQ.DOT .AND. BUF(J+1).EQ.BUF(J)) GO TO 11
IF (K.EQ.BSLASH .AND. N.EQ.1) GO TO 60
LIN(L) = K
IF (L.LT.1024) L = L+1
IF (L.EQ.1024) WRITE(WTE,33) L
33 FORMAT(1X,'INPUT BUFFER LIMIT IS ',I4,' CHARACTERS.')
40 CONTINUE
45 LIN(L) = EOL
LPT(6) = L
LPT(4) = LPT(1)
LPT(3) = 0
LPT(2) = 0
LCT(1) = 0
CALL GETCH
RETURN
C
50 IF (RIO .EQ. RTE) GO TO 52
CALL PUTID(LIN(L),RETU)
L = L + 4
GO TO 45
52 CALL FILES(-1*RTE,BUF)
LIN(L) = EOL
RETURN
C
60 N = LPT(6) - LPT(1)
DO 61 I = 1, N
J = L+I-1
K = LIN(J)
BUF(I) = ALFA(K+1)
IF (CASE.EQ.1 .AND. K.LT.36) BUF(I) = ALFB(K+1)
61 CONTINUE
CALL EDIT(BUF,N)
N = N + 1
GO TO 15
END
SUBROUTINE GETSYM
C GET A SYMBOL
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER ALFA(52),ALFB(52),ALFL,CASE
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /ALFS/ ALFA,ALFB,ALFL,CASE
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
SHAR_EOF
# End of shell archive
exit 0
--
Bob Page, U of Lowell CS Dept. page@swan.ulowell.edu ulowell!page
Have five nice days.