From: page@swan.ulowell.edu (Bob Page)
Newsgroups: comp.sources.amiga
Subject: v02i041:  matlab - matrix laboratory, Part01/11
Message-ID: <10016@swan.ulowell.edu>
Date: 2 Nov 88 21:38:51 GMT
Organization: University of Lowell, Computer Science Dept.
Lines: 1250
Approved: page@swan.ulowell.edu
 
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.