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 43
Archive-name: applications/matlab/src.3
# 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-3
# This archive created: Wed Nov 2 16:20:21 1988
cat << \SHAR_EOF > src-3
44 MRAT = IDINT(STKR(L))
LRAT = IDINT(STKR(L-1))
TOP = TOP - 1
MSTK(TOP) = 0
GO TO 99
C
C CHAR
50 K = IABS(IDINT(STKR(L)))
IF (M*N.NE.1 .OR. K.GE.ALFL) CALL ERROR(36)
IF (ERR .GT. 0) RETURN
CH = ALFA(K+1)
IF (STKR(L) .LT. 0.0D0) CH = ALFB(K+1)
WRITE(WTE,51) CH
51 FORMAT(1X,'REPLACE CHARACTER ',A1)
READ(RTE,52) CH
52 FORMAT(A1)
IF (STKR(L) .GE. 0.0D0) ALFA(K+1) = CH
IF (STKR(L) .LT. 0.0D0) ALFB(K+1) = CH
MSTK(TOP) = 0
GO TO 99
C
C DISP
60 WRITE(WTE,61)
IF (WIO .NE. 0) WRITE(WIO,61)
61 FORMAT(1X,80A1)
IF (RHS .EQ. 2) GO TO 65
MN = M*N
TEXT = .TRUE.
DO 62 I = 1, MN
LS = L+I-1
CH = IDINT(STKR(LS))
TEXT = TEXT .AND. (CH.GE.0) .AND. (CH.LT.ALFL)
TEXT = TEXT .AND. (DFLOAT(CH).EQ.STKR(LS))
62 CONTINUE
DO 64 I = 1, M
DO 63 J = 1, N
LS = L+I-1+(J-1)*M
IF (STKR(LS) .EQ. 0.0D0) CH = BLANK
IF (STKR(LS) .GT. 0.0D0) CH = PLUS
IF (STKR(LS) .LT. 0.0D0) CH = MINUS
IF (TEXT) CH = IDINT(STKR(LS))
BUF(J) = ALFA(CH+1)
63 CONTINUE
WRITE(WTE,61) (BUF(J),J=1,N)
IF (WIO .NE. 0) WRITE(WIO,61) (BUF(J),J=1,N)
64 CONTINUE
MSTK(TOP) = 0
GO TO 99
C
C BASE
65 IF (RHS .NE. 2) CALL ERROR(39)
IF (STKR(L) .LE. 1.0D0) CALL ERROR(36)
IF (ERR .GT. 0) RETURN
B = STKR(L)
L2 = L
TOP = TOP-1
RHS = 1
L = LSTK(TOP)
M = MSTK(TOP)*NSTK(TOP)
EPS = STKR(VSIZE-4)
DO 66 I = 1, M
LS = L2+(I-1)*N
LL = L+I-1
CALL BASE(STKR(LL),B,EPS,STKR(LS),N)
66 CONTINUE
CALL RSET(M*N,0.0D0,STKI(L2),1)
CALL WCOPY(M*N,STKR(L2),STKI(L2),1,STKR(L),STKI(L),1)
MSTK(TOP) = N
NSTK(TOP) = M
CALL STACK1(QUOTE)
IF (FIN .EQ. 6) GO TO 60
GO TO 99
C
C LINES
70 LCT(2) = IDINT(STKR(L))
MSTK(TOP) = 0
GO TO 99
C
C PLOT
80 IF (RHS .GE. 2) GO TO 82
N = M*N
DO 81 I = 1, N
LL = L+I-1
STKI(LL) = DFLOAT(I)
81 CONTINUE
CALL PLOT(WTE,STKI(L),STKR(L),N,T,0,BUF)
IF (WIO .NE. 0) CALL PLOT(WIO,STKI(L),STKR(L),N,T,0,BUF)
MSTK(TOP) = 0
GO TO 99
82 IF (RHS .EQ. 2) K = 0
IF (RHS .EQ. 3) K = M*N
IF (RHS .GT. 3) K = RHS - 2
TOP = TOP - (RHS - 1)
N = MSTK(TOP)*NSTK(TOP)
IF (MSTK(TOP+1)*NSTK(TOP+1) .NE. N) CALL ERROR(5)
IF (ERR .GT. 0) RETURN
LX = LSTK(TOP)
LY = LSTK(TOP+1)
IF (RHS .GT. 3) L = LSTK(TOP+2)
CALL PLOT(WTE,STKR(LX),STKR(LY),N,STKR(L),K,BUF)
IF (WIO .NE. 0) CALL PLOT(WIO,STKR(LX),STKR(LY),N,STKR(L),K,BUF)
MSTK(TOP) = 0
GO TO 99
C
C DEBUG
95 DDT = IDINT(STKR(L))
WRITE(WTE,96) DDT
96 FORMAT(1X,'DEBUG ',I4)
MSTK(TOP) = 0
GO TO 99
C
99 RETURN
END
SUBROUTINE MATFN6
C
C EVALUATE UTILITY FUNCTIONS
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
INTEGER SEMI,ID(4),UNIFOR(4),NORMAL(4),SEED(4)
DOUBLE PRECISION EPS0,EPS,S,SR,SI,T
DOUBLE PRECISION FLOP,URAND
LOGICAL EQID
DATA SEMI/39/
DATA UNIFOR/30,23,18,15/,NORMAL/23,24,27,22/,SEED/28,14,14,13/
C
IF (DDT .EQ. 1) WRITE(WTE,100) FIN
100 FORMAT(1X,'MATFN6',I4)
C FUNCTIONS/FIN
C MAGI DIAG SUM PROD USER EYE RAND ONES CHOP SIZE KRON TRIL TRIU
C 1 2 3 4 5 6 7 8 9 10 11-13 14 15
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
GO TO (75,80,65,67,70,90,90,90,60,77,50,50,50,80,80),FIN
C
C KRONECKER PRODUCT
50 IF (RHS .NE. 2) CALL ERROR(39)
IF (ERR .GT. 0) RETURN
TOP = TOP - 1
L = LSTK(TOP)
MA = MSTK(TOP)
NA = NSTK(TOP)
LA = L + MAX0(M*N*MA*NA,M*N+MA*NA)
LB = LA + MA*NA
ERR = LB + M*N - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
C MOVE A AND B ABOVE RESULT
CALL WCOPY(MA*NA+M*N,STKR(L),STKI(L),1,STKR(LA),STKI(LA),1)
DO 54 JA = 1, NA
DO 53 J = 1, N
LJ = LB + (J-1)*M
DO 52 IA = 1, MA
C GET J-TH COLUMN OF B
CALL WCOPY(M,STKR(LJ),STKI(LJ),1,STKR(L),STKI(L),1)
C ADDRESS OF A(IA,JA)
LS = LA + IA-1 + (JA-1)*MA
DO 51 I = 1, M
C A(IA,JA) OP B(I,J)
IF (FIN .EQ. 11) CALL WMUL(STKR(LS),STKI(LS),
$ STKR(L),STKI(L),STKR(L),STKI(L))
IF (FIN .EQ. 12) CALL WDIV(STKR(LS),STKI(LS),
$ STKR(L),STKI(L),STKR(L),STKI(L))
IF (FIN .EQ. 13) CALL WDIV(STKR(L),STKI(L),
$ STKR(LS),STKI(LS),STKR(L),STKI(L))
IF (ERR .GT. 0) RETURN
L = L + 1
51 CONTINUE
52 CONTINUE
53 CONTINUE
54 CONTINUE
MSTK(TOP) = M*MA
NSTK(TOP) = N*NA
GO TO 99
C
C CHOP
60 EPS0 = 1.0D0
61 EPS0 = EPS0/2.0D0
T = FLOP(1.0D0 + EPS0)
IF (T .GT. 1.0D0) GO TO 61
EPS0 = 2.0D0*EPS0
FLP(2) = IDINT(STKR(L))
IF (SYM .NE. SEMI) WRITE(WTE,62) FLP(2)
62 FORMAT(/1X,'CHOP ',I2,' PLACES.')
EPS = 1.0D0
63 EPS = EPS/2.0D0
T = FLOP(1.0D0 + EPS)
IF (T .GT. 1.0D0) GO TO 63
EPS = 2.0D0*EPS
T = STKR(VSIZE-4)
IF (T.LT.EPS .OR. T.EQ.EPS0) STKR(VSIZE-4) = EPS
MSTK(TOP) = 0
GO TO 99
C
C SUM
65 SR = 0.0D0
SI = 0.0D0
MN = M*N
DO 66 I = 1, MN
LS = L+I-1
SR = FLOP(SR+STKR(LS))
SI = FLOP(SI+STKI(LS))
66 CONTINUE
GO TO 69
C
C PROD
67 SR = 1.0D0
SI = 0.0D0
MN = M*N
DO 68 I = 1, MN
LS = L+I-1
CALL WMUL(STKR(LS),STKI(LS),SR,SI,SR,SI)
68 CONTINUE
69 STKR(L) = SR
STKI(L) = SI
MSTK(TOP) = 1
NSTK(TOP) = 1
GO TO 99
C
C USER
70 S = 0.0D0
T = 0.0D0
IF (RHS .LT. 2) GO TO 72
IF (RHS .LT. 3) GO TO 71
T = STKR(L)
TOP = TOP-1
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
71 S = STKR(L)
TOP = TOP-1
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
72 CALL USER(STKR(L),M,N,S,T)
CALL RSET(M*N,0.0D0,STKI(L),1)
MSTK(TOP) = M
NSTK(TOP) = N
GO TO 99
C
C MAGIC
75 N = MAX0(IDINT(STKR(L)),0)
IF (N .EQ. 2) N = 0
IF (N .GT. 0) CALL MAGIC(STKR(L),N,N)
CALL RSET(N*N,0.0D0,STKI(L),1)
MSTK(TOP) = N
NSTK(TOP) = N
GO TO 99
C
C SIZE
77 STKR(L) = M
STKR(L+1) = N
STKI(L) = 0.0D0
STKI(L+1) = 0.0D0
MSTK(TOP) = 1
NSTK(TOP) = 2
IF (LHS .EQ. 1) GO TO 99
NSTK(TOP) = 1
TOP = TOP + 1
LSTK(TOP) = L+1
MSTK(TOP) = 1
NSTK(TOP) = 1
GO TO 99
C
C DIAG, TRIU, TRIL
80 K = 0
IF (RHS .NE. 2) GO TO 81
K = IDINT(STKR(L))
TOP = TOP-1
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
81 IF (FIN .GE. 14) GO TO 85
IF (M .EQ. 1 .OR. N .EQ. 1) GO TO 83
IF (K.GE.0) MN=MIN0(M,N-K)
IF (K.LT.0) MN=MIN0(M+K,N)
MSTK(TOP) = MAX0(MN,0)
NSTK(TOP) = 1
IF (MN .LE. 0) GO TO 99
DO 82 I = 1, MN
IF (K.GE.0) LS = L+(I-1)+(I+K-1)*M
IF (K.LT.0) LS = L+(I-K-1)+(I-1)*M
LL = L+I-1
STKR(LL) = STKR(LS)
STKI(LL) = STKI(LS)
82 CONTINUE
GO TO 99
83 N = MAX0(M,N)+IABS(K)
ERR = L+N*N - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
MSTK(TOP) = N
NSTK(TOP) = N
DO 84 JB = 1, N
DO 84 IB = 1, N
J = N+1-JB
I = N+1-IB
SR = 0.0D0
SI = 0.0D0
IF (K.GE.0) LS = L+I-1
IF (K.LT.0) LS = L+J-1
LL = L+I-1+(J-1)*N
IF (J-I .EQ. K) SR = STKR(LS)
IF (J-I .EQ. K) SI = STKI(LS)
STKR(LL) = SR
STKI(LL) = SI
84 CONTINUE
GO TO 99
C
C TRIL, TRIU
85 DO 87 J = 1, N
LD = L + J - K - 1 + (J-1)*M
IF (FIN .EQ. 14) LL = J - K - 1
IF (FIN .EQ. 14) LS = LD - LL
IF (FIN .EQ. 15) LL = M - J + K
IF (FIN .EQ. 15) LS = LD + 1
IF (LL .GT. 0) CALL WSET(LL,0.0D0,0.0D0,STKR(LS),STKI(LS),1)
87 CONTINUE
GO TO 99
C
C EYE, RAND, ONES
90 IF (M.GT.1 .OR. RHS.EQ.0) GO TO 94
IF (RHS .NE. 2) GO TO 91
NN = IDINT(STKR(L))
TOP = TOP-1
L = LSTK(TOP)
N = NSTK(TOP)
91 IF (FIN.NE.7 .OR. N.LT.4) GO TO 93
DO 92 I = 1, 4
LS = L+I-1
ID(I) = IDINT(STKR(LS))
92 CONTINUE
IF (EQID(ID,UNIFOR).OR.EQID(ID,NORMAL)) GO TO 97
IF (EQID(ID,SEED)) GO TO 98
93 IF (N .GT. 1) GO TO 94
M = MAX0(IDINT(STKR(L)),0)
IF (RHS .EQ. 2) N = MAX0(NN,0)
IF (RHS .NE. 2) N = M
ERR = L+M*N - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
MSTK(TOP) = M
NSTK(TOP) = N
IF (M*N .EQ. 0) GO TO 99
94 DO 96 J = 1, N
DO 96 I = 1, M
LL = L+I-1+(J-1)*M
STKR(LL) = 0.0D0
STKI(LL) = 0.0D0
IF (I.EQ.J .OR. FIN.EQ.8) STKR(LL) = 1.0D0
IF (FIN.EQ.7 .AND. RAN(2).EQ.0) STKR(LL) = FLOP(URAND(RAN(1)))
IF (FIN.NE.7 .OR. RAN(2).EQ.0) GO TO 96
95 SR = 2.0D0*URAND(RAN(1))-1.0D0
SI = 2.0D0*URAND(RAN(1))-1.0D0
T = SR*SR + SI*SI
IF (T .GT. 1.0D0) GO TO 95
STKR(LL) = FLOP(SR*DSQRT(-2.0D0*DLOG(T)/T))
96 CONTINUE
GO TO 99
C
C SWITCH UNIFORM AND NORMAL
97 RAN(2) = ID(1) - UNIFOR(1)
MSTK(TOP) = 0
GO TO 99
C
C SEED
98 IF (RHS .EQ. 2) RAN(1) = NN
STKR(L) = RAN(1)
MSTK(TOP) = 1
IF (RHS .EQ. 2) MSTK(TOP) = 0
NSTK(TOP) = 1
GO TO 99
C
99 RETURN
END
SUBROUTINE MATLAB(INIT)
C INIT = 0 FOR ORDINARY FIRST ENTRY
C = POSITIVE FOR SUBSEQUENT ENTRIES
C = NEGATIVE FOR SILENT INITIALIZATION (SEE MATZ)
C
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
C
DOUBLE PRECISION S,T
INTEGER EPS(4),FLOPS(4),EYE(4),RAND(4)
C
C CHARACTER SET
C 0 10 20 30 40 50
C
C 0 0 A K U COLON : LESS <
C 1 1 B L V PLUS + GREAT >
C 2 2 C M W MINUS -
C 3 3 D N X STAR *
C 4 4 E O Y SLASH /
C 5 5 F P Z BSLASH \
C 6 6 G Q BLANK EQUAL =
C 7 7 H R LPAREN ( DOT .
C 8 8 I S RPAREN ) COMMA ,
C 9 9 J T SEMI ; QUOTE '
C
INTEGER ALPHA(52),ALPHB(52)
DATA ALPHA /1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,
$ 1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
$ 1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,
$ 1HU,1HV,1HW,1HX,1HY,1HZ,1H ,1H(,1H),1H;,
$ 1H:,1H+,1H-,1H*,1H/,1H\,1H=,1H.,1H,,1H',
$ 1H<,1H>/
C
C ALTERNATE CHARACTER SET
C
DATA ALPHB /1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,
$ 1Ha,1Hb,1Hc,1Hd,1He,1Hf,1Hg,1Hh,1Hi,1Hj,
$ 1Hk,1Hl,1Hm,1Hn,1Ho,1Hp,1Hq,1Hr,1Hs,1Ht,
$ 1Hu,1Hv,1Hw,1Hx,1Hy,1Hz,1H ,1H(,1H),1H;,
$ 1H|,1H+,1H-,1H*,1H/,1H$,1H=,1H.,1H,,1H",
$ 1H[,1H]/
C
DATA EPS/14,25,28,36/,FLOPS/15,21,24,25/
DATA EYE/14,34,14,36/,RAND/27,10,23,13/
C
IF (INIT .GT. 0) GO TO 90
C
C RTE = UNIT NUMBER FOR TERMINAL INPUT
RTE = 9
CALL FILES(RTE,BUF)
RIO = RTE
C
C WTE = UNIT NUMBER FOR TERMINAL OUTPUT
WTE = 9
CALL FILES(WTE,BUF)
WIO = 0
C
IF (INIT .GE. 0) WRITE(WTE,100)
100 FORMAT(//1X,' < M A T L A B >'
$ /1X,' Version of 05/25/82')
C
C HIO = UNIT NUMBER FOR HELP FILE
HIO = 11
CALL FILES(HIO,BUF)
C
C RANDOM NUMBER SEED
RAN(1) = 0
C
C INITIAL LINE LIMIT
LCT(2) = 25
C
ALFL = 52
CASE = 0
C CASE = 1 for file names in lower case
DO 20 I = 1, ALFL
ALFA(I) = ALPHA(I)
ALFB(I) = ALPHB(I)
20 CONTINUE
C
VSIZE = 5005
LSIZE = 48
PSIZE = 32
BOT = LSIZE-3
CALL WSET(5,0.0D0,0.0D0,STKR(VSIZE-4),STKI(VSIZE-4),1)
CALL PUTID(IDSTK(1,LSIZE-3),EPS)
LSTK(LSIZE-3) = VSIZE-4
MSTK(LSIZE-3) = 1
NSTK(LSIZE-3) = 1
S = 1.0D0
30 S = S/2.0D0
T = 1.0D0 + S
IF (T .GT. 1.0D0) GO TO 30
STKR(VSIZE-4) = 2.0D0*S
CALL PUTID(IDSTK(1,LSIZE-2),FLOPS)
LSTK(LSIZE-2) = VSIZE-3
MSTK(LSIZE-2) = 1
NSTK(LSIZE-2) = 2
CALL PUTID(IDSTK(1,LSIZE-1), EYE)
LSTK(LSIZE-1) = VSIZE-1
MSTK(LSIZE-1) = -1
NSTK(LSIZE-1) = -1
STKR(VSIZE-1) = 1.0D0
CALL PUTID(IDSTK(1,LSIZE), RAND)
LSTK(LSIZE) = VSIZE
MSTK(LSIZE) = 1
NSTK(LSIZE) = 1
FMT = 1
FLP(1) = 0
FLP(2) = 0
DDT = 0
RAN(2) = 0
PTZ = 0
PT = PTZ
ERR = 0
IF (INIT .LT. 0) RETURN
C
90 CALL PARSE
IF (FUN .EQ. 1) CALL MATFN1
IF (FUN .EQ. 2) CALL MATFN2
IF (FUN .EQ. 3) CALL MATFN3
IF (FUN .EQ. 4) CALL MATFN4
IF (FUN .EQ. 5) CALL MATFN5
IF (FUN .EQ. 6) CALL MATFN6
IF (FUN .EQ. 21) CALL MATFN1
IF (FUN .NE. 99) GO TO 90
RETURN
END
SUBROUTINE PARSE
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
LOGICAL EQID
INTEGER SEMI,EQUAL,EOL,ID(4),EXCNT,LPAREN,RPAREN,COLON,PTS,ALFL
INTEGER BLANK,COMMA,LESS,GREAT,NAME,ANS(4),ENND(4),ELSE(4),P,R
DATA BLANK/36/,SEMI/39/,EQUAL/46/,EOL/99/,COMMA/48/,COLON/40/
DATA LPAREN/37/,RPAREN/38/,LESS/50/,GREAT/51/,NAME/1/,ALFL/52/
DATA ANS/10,23,28,36/,ENND/14,23,13,36/,ELSE/14,21,28,14/
C
01 R = 0
IF (ERR .GT. 0) PTZ = 0
IF (ERR.LE.0 .AND. PT.GT.PTZ) R = RSTK(PT)
IF (DDT .EQ. 1) WRITE(WTE,100) PT,R,PTZ,ERR
100 FORMAT(1X,'PARSE ',4I4)
IF (R.EQ.15) GO TO 93
IF (R.EQ.16 .OR. R.EQ.17) GO TO 94
SYM = EOL
TOP = 0
IF (RIO .NE. RTE) CALL FILES(-1*RIO,BUF)
RIO = RTE
LCT(3) = 0
LCT(4) = 2
LPT(1) = 1
10 IF (SYM.EQ.EOL .AND. MOD(LCT(4)/2,2).EQ.1) CALL PROMPT(LCT(4)/4)
IF (SYM .EQ. EOL) CALL GETLIN
ERR = 0
PT = PTZ
15 EXCNT = 0
IF (DDT .EQ. 1) WRITE(WTE,115) PT,TOP
115 FORMAT(1X,'STATE ',2I4)
LHS = 1
CALL PUTID(ID,ANS)
CALL GETSYM
IF (SYM.EQ.COLON .AND. CHAR.EQ.EOL) DDT = 1-DDT
IF (SYM .EQ. COLON) CALL GETSYM
IF (SYM.EQ.SEMI .OR. SYM.EQ.COMMA .OR. SYM.EQ.EOL) GO TO 80
IF (SYM .EQ. NAME) GO TO 20
IF (SYM .EQ. LESS) GO TO 40
IF (SYM .EQ. GREAT) GO TO 45
GO TO 50
C
C LHS BEGINS WITH NAME
20 CALL COMAND(SYN)
IF (ERR .GT. 0) GO TO 01
IF (FUN .EQ. 99) GO TO 95
IF (FIN .EQ. -15) GO TO 80
IF (FIN .LT. 0) GO TO 91
IF (FIN .GT. 0) GO TO 70
C IF NAME IS A FUNCTION, MUST BE RHS
RHS = 0
CALL FUNS(SYN)
IF (FIN .NE. 0) GO TO 50
C PEEK ONE CHARACTER AHEAD
IF (CHAR.EQ.SEMI .OR. CHAR.EQ.COMMA .OR. CHAR.EQ.EOL)
$ CALL PUTID(ID,SYN)
IF (CHAR .EQ. EQUAL) GO TO 25
IF (CHAR .EQ. LPAREN) GO TO 30
GO TO 50
C
C LHS IS SIMPLE VARIABLE
25 CALL PUTID(ID,SYN)
CALL GETSYM
CALL GETSYM
GO TO 50
C
C LHS IS NAME(...)
30 LPT(5) = LPT(4)
CALL PUTID(ID,SYN)
CALL GETSYM
32 CALL GETSYM
EXCNT = EXCNT+1
PT = PT+1
CALL PUTID(IDS(1,PT), ID)
PSTK(PT) = EXCNT
RSTK(PT) = 1
C *CALL* EXPR
GO TO 92
35 CALL PUTID(ID,IDS(1,PT))
EXCNT = PSTK(PT)
PT = PT-1
IF (SYM .EQ. COMMA) GO TO 32
IF (SYM .NE. RPAREN) CALL ERROR(3)
IF (ERR .GT. 0) GO TO 01
IF (ERR .GT. 0) RETURN
IF (SYM .EQ. RPAREN) CALL GETSYM
IF (SYM .EQ. EQUAL) GO TO 50
C LHS IS REALLY RHS, FORGET SCAN JUST DONE
TOP = TOP - EXCNT
LPT(4) = LPT(5)
CHAR = LPAREN
SYM = NAME
CALL PUTID(SYN,ID)
CALL PUTID(ID,ANS)
EXCNT = 0
GO TO 50
C
C MULTIPLE LHS
40 LPT(5) = LPT(4)
PTS = PT
CALL GETSYM
41 IF (SYM .NE. NAME) GO TO 43
CALL PUTID(ID,SYN)
CALL GETSYM
IF (SYM .EQ. GREAT) GO TO 42
IF (SYM .EQ. COMMA) CALL GETSYM
PT = PT+1
LHS = LHS+1
PSTK(PT) = 0
CALL PUTID(IDS(1,PT),ID)
GO TO 41
42 CALL GETSYM
IF (SYM .EQ. EQUAL) GO TO 50
43 LPT(4) = LPT(5)
PT = PTS
LHS = 1
SYM = LESS
CHAR = LPT(4)-1
CHAR = LIN(CHAR)
CALL PUTID(ID,ANS)
GO TO 50
C
C MACRO STRING
45 CALL GETSYM
IF (DDT .EQ. 1) WRITE(WTE,145) PT,TOP
145 FORMAT(1X,'MACRO ',2I4)
IF (SYM.EQ.LESS .AND. CHAR.EQ.EOL) CALL ERROR(28)
IF (ERR .GT. 0) GO TO 01
PT = PT+1
RSTK(PT) = 20
C *CALL* EXPR
GO TO 92
46 PT = PT-1
IF (SYM.NE.LESS .AND. SYM.NE.EOL) CALL ERROR(37)
IF (ERR .GT. 0) GO TO 01
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 48 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,47) K
47 FORMAT(1X,'INPUT BUFFER LIMIT IS ',I4,' CHARACTERS.')
48 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
PT = PT+1
PSTK(PT) = LPT(1)
RSTK(PT) = 21
C *CALL* PARSE
GO TO 15
49 PT = PT-1
IF (DDT .EQ. 1) WRITE(WTE,149) PT,TOP
149 FORMAT(1X,'MACEND',2I4)
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 80
C
C LHS FINISHED, START RHS
50 IF (SYM .EQ. EQUAL) CALL GETSYM
PT = PT+1
CALL PUTID(IDS(1,PT),ID)
PSTK(PT) = EXCNT
RSTK(PT) = 2
C *CALL* EXPR
GO TO 92
55 IF (SYM.EQ.SEMI .OR. SYM.EQ.COMMA .OR. SYM.EQ.EOL) GO TO 60
IF (SYM.EQ.NAME .AND. EQID(SYN,ELSE)) GO TO 60
IF (SYM.EQ.NAME .AND. EQID(SYN,ENND)) GO TO 60
CALL ERROR(40)
IF (ERR .GT. 0) GO TO 01
C
C STORE RESULTS
60 RHS = PSTK(PT)
CALL STACKP(IDS(1,PT))
IF (ERR .GT. 0) GO TO 01
PT = PT-1
LHS = LHS-1
IF (LHS .GT. 0) GO TO 60
GO TO 70
C
C UPDATE AND POSSIBLY PRINT OPERATION COUNTS
70 K = FLP(1)
IF (K .NE. 0) STKR(VSIZE-3) = DFLOAT(K)
STKR(VSIZE-2) = STKR(VSIZE-2) + DFLOAT(K)
FLP(1) = 0
IF (.NOT.(CHAR.EQ.COMMA .OR. (SYM.EQ.COMMA .AND. CHAR.EQ.EOL)))
$ GO TO 80
CALL GETSYM
I5 = 10**5
LUNIT = WTE
71 IF (K .EQ. 0) WRITE(LUNIT,171)
171 FORMAT(/1X,' no flops')
IF (K .EQ. 1) WRITE(LUNIT,172)
172 FORMAT(/1X,' 1 flop')
IF (1.LT.K .AND. K.LT.100000) WRITE(LUNIT,173) K
173 FORMAT(/1X,I5,' flops')
IF (100000 .LE. K) WRITE(LUNIT,174) K
174 FORMAT(/1X,I9,' flops')
IF (LUNIT.EQ.WIO .OR. WIO.EQ.0) GO TO 80
LUNIT = WIO
GO TO 71
C
C FINISH STATEMENT
80 FIN = 0
P = 0
R = 0
IF (PT .GT. 0) P = PSTK(PT)
IF (PT .GT. 0) R = RSTK(PT)
IF (DDT .EQ. 1) WRITE(WTE,180) PT,PTZ,P,R,LPT(1)
180 FORMAT(1X,'FINISH',5I4)
IF (SYM.EQ.COMMA .OR. SYM.EQ.SEMI) GO TO 15
IF (R.EQ.21 .AND. P.EQ.LPT(1)) GO TO 49
IF (PT .GT. PTZ) GO TO 91
GO TO 10
C
C SIMULATE RECURSION
91 CALL CLAUSE
IF (ERR .GT. 0) GO TO 01
IF (PT .LE. PTZ) GO TO 15
R = RSTK(PT)
IF (R .EQ. 21) GO TO 49
GO TO (99,99,92,92,92,99,99,99,99,99,99,99,15,15,99,99,99,99,99),R
C
92 CALL EXPR
IF (ERR .GT. 0) GO TO 01
R = RSTK(PT)
GO TO (35,55,91,91,91,93,93,99,99,94,94,99,99,99,99,99,99,94,94,
$ 46),R
C
93 CALL TERM
IF (ERR .GT. 0) GO TO 01
R = RSTK(PT)
GO TO (99,99,99,99,99,92,92,94,94,99,99,99,99,99,95,99,99,99,99),R
C
94 CALL FACTOR
IF (ERR .GT. 0) GO TO 01
R = RSTK(PT)
GO TO (99,99,99,99,99,99,99,93,93,92,92,94,99,99,99,95,95,92,92),R
C
C CALL MATFNS BY RETURNING TO MATLAB
95 IF (FIN.GT.0 .AND. MSTK(TOP).LT.0) CALL ERROR(14)
IF (ERR .GT. 0) GO TO 01
RETURN
C
99 CALL ERROR(22)
GO TO 01
END
SUBROUTINE PLOT(LUNIT,X,Y,N,P,K,BUF)
DOUBLE PRECISION X(N),Y(N),P(1)
INTEGER BUF(79)
C
C PLOT X VS. Y ON LUNIT
C IF K IS NONZERO, THEN P(1),...,P(K) ARE EXTRA PARAMETERS
C BUF IS WORK SPACE
C
DOUBLE PRECISION XMIN,YMIN,XMAX,YMAX,DY,DX,Y1,Y0
INTEGER AST,BLANK,H,W
DATA AST/1H*/,BLANK/1H /,H/20/,W/79/
C
C H = HEIGHT, W = WIDTH
C
IF (K .GT. 0) WRITE(LUNIT,01) (P(I), I=1,K)
01 FORMAT('Extra parameters',10f5.1)
XMIN = X(1)
XMAX = X(1)
YMIN = Y(1)
YMAX = Y(1)
DO 10 I = 1, N
XMIN = DMIN1(XMIN,X(I))
XMAX = DMAX1(XMAX,X(I))
YMIN = DMIN1(YMIN,Y(I))
YMAX = DMAX1(YMAX,Y(I))
10 CONTINUE
DX = XMAX - XMIN
IF (DX .EQ. 0.0D0) DX = 1.0D0
DY = YMAX - YMIN
WRITE(LUNIT,35)
DO 40 L = 1, H
DO 20 J = 1, W
BUF(J) = BLANK
20 CONTINUE
Y1 = YMIN + (H-L+1)*DY/H
Y0 = YMIN + (H-L)*DY/H
JMAX = 1
DO 30 I = 1, N
IF (Y(I) .GT. Y1) GO TO 30
IF (L.NE.H .AND. Y(I).LE.Y0) GO TO 30
J = 1 + (W-1)*(X(I) - XMIN)/DX
BUF(J) = AST
JMAX = MAX0(JMAX,J)
30 CONTINUE
WRITE(LUNIT,35) (BUF(J),J=1,JMAX)
35 FORMAT(79A1)
40 CONTINUE
RETURN
END
SUBROUTINE PRINT(ID,K)
C PRIMARY OUTPUT ROUTINE
INTEGER ID(4),K
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
DOUBLE PRECISION S,TR,TI,PR(12),PI(12),ROUND
INTEGER FNO(11),FNL(11),SIG(12),PLUS,MINUS,BLANK,TYP,F
DATA PLUS/41/,MINUS/42/,BLANK/36/
C FORMAT NUMBERS AND LENGTHS
DATA FNO /11,12,21,22,23,24,31,32,33,34,-1/
DATA FNL /12, 6, 8, 4, 6, 3, 4, 2, 3, 1, 1/
C FMT 1 2 3 4 5
C SHORT LONG SHORT E LONG E Z
C TYP 1 2 3
C INTEGER REAL COMPLEX
IF (LCT(1) .LT. 0) GO TO 99
L = LSTK(K)
M = MSTK(K)
N = NSTK(K)
MN = M*N
TYP = 1
S = 0.0D0
DO 10 I = 1, MN
LS = L+I-1
TR = STKR(LS)
TI = STKI(LS)
S = DMAX1(S,DABS(TR),DABS(TI))
IF (ROUND(TR) .NE. TR) TYP = MAX0(2,TYP)
IF (TI .NE. 0.0D0) TYP = 3
10 CONTINUE
IF (S .NE. 0.0D0) S = DLOG10(S)
KS = IDINT(S)
IF (-2 .LE. KS .AND. KS .LE. 1) KS = 0
IF (KS .EQ. 2 .AND. FMT .EQ. 1 .AND. TYP .EQ. 2) KS = 0
IF (TYP .EQ. 1 .AND. KS .LE. 2) F = 1
IF (TYP .EQ. 1 .AND. KS .GT. 2) F = 2
IF (TYP .EQ. 1 .AND. KS .GT. 9) TYP = 2
IF (TYP .EQ. 2) F = FMT + 2
IF (TYP .EQ. 3) F = FMT + 6
IF (MN.EQ.1 .AND. KS.NE.0 .AND. FMT.LT.3 .AND. TYP.NE.1) F = F+2
IF (FMT .EQ. 5) F = 11
JINC = FNL(F)
F = FNO(F)
S = 1.0D0
IF (F.EQ.21 .OR. F.EQ.22 .OR. F.EQ.31 .OR. F.EQ.32) S = 10.0D0**KS
LS = ((N-1)/JINC+1)*M + 2
IF (LCT(1) + LS .LE. LCT(2)) GO TO 20
LCT(1) = 0
WRITE(WTE,43) LS
READ(RTE,44,END=19) LS
CDC.. IF (EOF(RTE).NE.0) GO TO 19
IF (LS .EQ. ALFA(BLANK+1)) GO TO 20
LCT(1) = -1
GO TO 99
19 CALL FILES(-1*RTE,BUF)
20 CONTINUE
WRITE(WTE,44)
IF (WIO .NE. 0) WRITE(WIO,44)
CALL PRNTID(ID,-1)
LCT(1) = LCT(1)+2
LUNIT = WTE
50 IF (S .NE. 1.0D0) WRITE(LUNIT,41) S
DO 80 J1 = 1, N, JINC
J2 = MIN0(N, J1+JINC-1)
WRITE(LUNIT,44)
IF (N .GT. JINC) WRITE(LUNIT,42) J1,J2
DO 70 I = 1, M
JM = J2-J1+1
DO 60 J = 1, JM
LS = L+I-1+(J+J1-2)*M
PR(J) = STKR(LS)/S
PI(J) = DABS(STKI(LS)/S)
SIG(J) = ALFA(PLUS+1)
IF (STKI(LS) .LT. 0.0D0) SIG(J) = ALFA(MINUS+1)
60 CONTINUE
IF (F .EQ. 11) WRITE(LUNIT,11)(PR(J),J=1,JM)
IF (F .EQ. 12) WRITE(LUNIT,12)(PR(J),J=1,JM)
IF (F .EQ. 21) WRITE(LUNIT,21)(PR(J),J=1,JM)
IF (F .EQ. 22) WRITE(LUNIT,22)(PR(J),J=1,JM)
IF (F .EQ. 23) WRITE(LUNIT,23)(PR(J),J=1,JM)
IF (F .EQ. 24) WRITE(LUNIT,24)(PR(J),J=1,JM)
IF (F .EQ. 31) WRITE(LUNIT,31)(PR(J),SIG(J),PI(J),J=1,JM)
IF (F .EQ. 32) WRITE(LUNIT,32)(PR(J),SIG(J),PI(J),J=1,JM)
IF (F .EQ. 33) WRITE(LUNIT,33)(PR(J),SIG(J),PI(J),J=1,JM)
IF (F .EQ. 34) WRITE(LUNIT,34)(PR(J),SIG(J),PI(J),J=1,JM)
IF (F .EQ. -1) CALL FORMZ(LUNIT,STKR(LS),STKI(LS))
LCT(1) = LCT(1)+1
70 CONTINUE
80 CONTINUE
IF (LUNIT.EQ.WIO .OR. WIO.EQ.0) GO TO 99
LUNIT = WIO
GO TO 50
99 RETURN
C
11 FORMAT(1X,12F6.0)
12 FORMAT(1X,6F12.0)
21 FORMAT(1X,F9.4,7F10.4)
22 FORMAT(1X,F19.15,3F20.15)
23 FORMAT(1X,1P6D13.4)
24 FORMAT(1X,1P3D24.15)
31 FORMAT(1X,4(F9.4,' ',A1,F7.4,'i'))
32 FORMAT(1X,F19.15,A1,F18.15,'i',F20.15,A1,F18.15,'i')
33 FORMAT(1X,3(1PD13.4,' ',A1,1PD10.4,'i'))
34 FORMAT(1X,1PD24.15,' ',A1,1PD21.15,'i')
41 FORMAT(/1X,' ',1PD9.1,2H *)
42 FORMAT(1X,' COLUMNS',I3,' THRU',I3)
43 FORMAT(/1X,'AT LEAST ',I5,' MORE LINES.',
$ ' ENTER BLANK LINE TO CONTINUE OUTPUT.')
44 FORMAT(A1)
C
END
SUBROUTINE PRNTID(ID,ARGCNT)
C PRINT VARIABLE NAMES
INTEGER ID(4,1),ARGCNT
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 EQUAL
DATA EQUAL/46/
J1 = 1
10 J2 = MIN0(J1+7,IABS(ARGCNT))
L = 0
DO 15 J = J1,J2
DO 15 I = 1, 4
K = ID(I,J)+1
L = L+1
BUF(L) = ALFA(K)
15 CONTINUE
IF (ARGCNT .EQ. -1) L=L+1
IF (ARGCNT .EQ. -1) BUF(L) = ALFA(EQUAL+1)
WRITE(WTE,20) (BUF(I),I=1,L)
IF (WIO .NE. 0) WRITE(WIO,20) (BUF(I),I=1,L)
20 FORMAT(1X,8(4A1,2H ))
J1 = J1+8
IF (J1 .LE. IABS(ARGCNT)) GO TO 10
RETURN
END
SUBROUTINE PROMPT(PAUSE)
INTEGER PAUSE
C
C ISSUE MATLAB PROMPT WITH OPTIONAL PAUSE
C
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
WRITE(WTE,10)
IF (WIO .NE. 0) WRITE(WIO,10)
10 FORMAT(/1X,'<>',$)
IF (PAUSE .EQ. 1) READ(RTE,20) DUMMY
20 FORMAT(A1)
RETURN
END
DOUBLE PRECISION FUNCTION PYTHAG(A,B)
DOUBLE PRECISION A,B
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
DOUBLE PRECISION P,Q,R,S,T
P = DMAX1(DABS(A),DABS(B))
Q = DMIN1(DABS(A),DABS(B))
IF (Q .EQ. 0.0D0) GO TO 20
IF (DDT .EQ. 25) WRITE(WTE,1)
IF (DDT .EQ. 25) WRITE(WTE,2) P,Q
1 FORMAT(1X,'PYTHAG',1P2D23.15)
2 FORMAT(1X,1P2D23.15)
10 R = (Q/P)**2
T = 4.0D0 + R
IF (T .EQ. 4.0D0) GO TO 20
S = R/T
P = P + 2.0D0*P*S
Q = Q*S
IF (DDT .EQ. 25) WRITE(WTE,2) P,Q
GO TO 10
20 PYTHAG = P
RETURN
END
SUBROUTINE RAT(X,LEN,MAXD,A,B,D)
INTEGER LEN,MAXD
DOUBLE PRECISION X,A,B,D(LEN)
C
C A/B = CONTINUED FRACTION APPROXIMATION TO X
C USING LEN TERMS EACH LESS THAN MAXD
C
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
DOUBLE PRECISION S,T,Z,ROUND
Z = X
DO 10 I = 1, LEN
K = I
D(K) = ROUND(Z)
Z = Z - D(K)
IF (DABS(Z)*DFLOAT(MAXD) .LE. 1.0D0) GO TO 20
Z = 1.0D0/Z
10 CONTINUE
20 T = D(K)
S = 1.0D0
IF (K .LT. 2) GO TO 40
DO 30 IB = 2, K
I = K+1-IB
Z = T
T = D(I)*T + S
S = Z
30 CONTINUE
40 IF (S .LT. 0.0D0) T = -T
IF (S .LT. 0.0D0) S = -S
IF (DDT .EQ. 27) WRITE(WTE,50) X,T,S,(D(I),I=1,K)
50 FORMAT(/1X,1PD23.15,0PF8.0,' /',F8.0,4X,6F5.0/(1X,45X,6F5.0))
A = T
B = S
RETURN
END
SUBROUTINE SAVLOD(LUNIT,ID,M,N,IMG,JOB,XREAL,XIMAG)
INTEGER LUNIT,ID(4),M,N,IMG,JOB
DOUBLE PRECISION XREAL(1),XIMAG(1)
C
C IMPLEMENT SAVE AND LOAD
C LUNIT = LOGICAL UNIT NUMBER
C ID = NAME, FORMAT 4A1
C M, N = DIMENSIONS
C IMG = NONZERO IF XIMAG IS NONZERO
C JOB = 0 FOR SAVE
C = SPACE AVAILABLE FOR LOAD
C XREAL, XIMAG = REAL AND OPTIONAL IMAGINARY PARTS
C
C SYSTEM DEPENDENT FORMATS
101 FORMAT(4A1,3I4)
102 FORMAT(4Z18)
C
IF (JOB .GT. 0) GO TO 20
C
C SAVE
10 WRITE(LUNIT,101) ID,M,N,IMG
DO 15 J = 1, N
K = (J-1)*M+1
L = J*M
WRITE(LUNIT,102) (XREAL(I),I=K,L)
IF (IMG .NE. 0) WRITE(LUNIT,102) (XIMAG(I),I=K,L)
15 CONTINUE
RETURN
C
C LOAD
20 READ(LUNIT,101,END=30) ID,M,N,IMG
IF (M*N .GT. JOB) GO TO 30
DO 25 J = 1, N
K = (J-1)*M+1
L = J*M
READ(LUNIT,102,END=30) (XREAL(I),I=K,L)
IF (IMG .NE. 0) READ(LUNIT,102,END=30) (XIMAG(I),I=K,L)
25 CONTINUE
RETURN
C
C END OF FILE
30 M = 0
N = 0
RETURN
END
SUBROUTINE STACK1(OP)
INTEGER OP
C
C UNARY OPERATIONS
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
INTEGER QUOTE
DATA QUOTE/49/
IF (DDT .EQ. 1) WRITE(WTE,100) OP
100 FORMAT(1X,'STACK1',I4)
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
MN = M*N
IF (MN .EQ. 0) GO TO 99
IF (OP .EQ. QUOTE) GO TO 30
C
C UNARY MINUS
CALL WRSCAL(MN,-1.0D0,STKR(L),STKI(L),1)
GO TO 99
C
C TRANSPOSE
30 LL = L + MN
ERR = LL+MN - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
CALL WCOPY(MN,STKR(L),STKI(L),1,STKR(LL),STKI(LL),1)
M = NSTK(TOP)
N = MSTK(TOP)
MSTK(TOP) = M
NSTK(TOP) = N
DO 50 I = 1, M
DO 50 J = 1, N
LS = L+MN+(J-1)+(I-1)*N
LL = L+(I-1)+(J-1)*M
STKR(LL) = STKR(LS)
STKI(LL) = -STKI(LS)
50 CONTINUE
GO TO 99
99 RETURN
END
SUBROUTINE STACK2(OP)
INTEGER OP
C
C BINARY AND TERNARY OPERATIONS
C
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
DOUBLE PRECISION WDOTUR,WDOTUI
DOUBLE PRECISION SR,SI,E1,ST,E2,FLOP
INTEGER PLUS,MINUS,STAR,DSTAR,SLASH,BSLASH,DOT,COLON
DATA PLUS/41/,MINUS/42/,STAR/43/,DSTAR/54/,SLASH/44/
DATA BSLASH/45/,DOT/47/,COLON/40/
C
IF (DDT .EQ. 1) WRITE(WTE,100) OP
100 FORMAT(1X,'STACK2',I4)
L2 = LSTK(TOP)
M2 = MSTK(TOP)
N2 = NSTK(TOP)
TOP = TOP-1
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
FUN = 0
IF (OP .EQ. PLUS) GO TO 01
IF (OP .EQ. MINUS) GO TO 03
IF (OP .EQ. STAR) GO TO 05
IF (OP .EQ. DSTAR) GO TO 30
IF (OP .EQ. SLASH) GO TO 20
IF (OP .EQ. BSLASH) GO TO 25
IF (OP .EQ. COLON) GO TO 60
IF (OP .GT. 2*DOT) GO TO 80
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.