C     PROGRAM MAIN FOR Amiga
      PROGRAM MAIN

      INTEGER*4 WBST
      INTEGER*4 WBSTRT
      CHARACTER*1 CONDEF(34)
      CHARACTER*34 CONDEF2
      EQUIVALENCE (CONDEF,CONDEF2)
      COMMON /SYS/ WBST

      CONDEF2 = 'CON:0/0/640/200/Amiga Matlab'//CHAR(0)
C
C DETERMINE WHETHER WE STARTED FROM WORKBENCH
C
      WBST = WBSTRT(0)
C
C IF SO, LOCATE AND LOAD THE MATLAB CONFIGURATION FILE
C
      IF(WBST .NE. 0) THEN
        OPEN(46,FILE = 'MATCONFIG.SYS',STATUS = 'OLD', ERR=15)
        READ(46,5)(CONDEF(J),J=1,33)
5       FORMAT(33A1)
        CONDEF(34)=CHAR(0)
        CLOSE(46)
      ENDIF
15    CONTINUE
      CALL STDOPN(CONDEF2)
C
C BEGIN MATLAB
C
      CALL MATLAB(0)
      CALL WBEND
      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)
      INTEGER*4 COLOR1,COLOR2,COLOR3,BGRP
      LOGICAL PLTST,SETBG
      COMMON /MATPLT/ COLOR1,COLOR2,COLOR3,BGRP,PLTST,SETBG
      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'/)
      IF(PLTST) THEN
       CALL PLTFIN
       CALL RLSDEV
      ENDIF
      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)
      INTEGER COLOR1,COLOR2
      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 /
      DATA COLOR1/Z'9B33326D'/,COLOR2/Z'9B30306D'/
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) COLOR1,(BLH,I=1,K),(ERRMSG(I),I=1,8),COLOR2,BEL
  100 FORMAT(1X,A4,80A1,A4)
      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
      DOUBLE PRECISION SYV,S,FLOP
      INTEGER BLANK,Z,DOT,D,E,PLUS,MINUS,NAME,NUM,SIGN,CHCNT,EOL
      INTEGER STAR,SLASH,BSLASH,SS
      DATA BLANK/36/,Z/35/,DOT/47/,D/13/,E/14/,EOL/99/,PLUS/41/
      DATA MINUS/42/,NAME/1/,NUM/0/,STAR/43/,SLASH/44/,BSLASH/45/
   10 IF (CHAR .NE. BLANK) GO TO 20
      CALL GETCH
      GO TO 10
   20 LPT(2) = LPT(3)
      LPT(3) = LPT(4)
      IF (CHAR .LE. 9) GO TO 50
      IF (CHAR .LE. Z) GO TO 30
C
C     SPECIAL CHARACTER
      SS = SYM
      SYM = CHAR
      CALL GETCH
      IF (SYM .NE. DOT) GO TO 90
C
C     IS DOT PART OF NUMBER OR OPERATOR
      SYV = 0.0D0
      IF (CHAR .LE. 9) GO TO 55
      IF (CHAR.EQ.STAR .OR. CHAR.EQ.SLASH .OR. CHAR.EQ.BSLASH) GO TO 90
      IF (SS.EQ.STAR .OR. SS.EQ.SLASH .OR. SS.EQ.BSLASH) GO TO 90
      GO TO 55
C
C     NAME
   30 SYM = NAME
      SYN(1) = CHAR
      CHCNT = 1
   40 CALL GETCH
      CHCNT = CHCNT+1
      IF (CHAR .GT. Z) GO TO 45
      IF (CHCNT .LE. 4) SYN(CHCNT) = CHAR
      GO TO 40
   45 IF (CHCNT .GT. 4) GO TO 47
      DO 46 I = CHCNT, 4
   46 SYN(I) = BLANK
   47 CONTINUE
      GO TO 90
C
C     NUMBER
   50 CALL GETVAL(SYV)
      IF (CHAR .NE. DOT) GO TO 60
      CALL GETCH
   55 CHCNT = LPT(4)
      CALL GETVAL(S)
      CHCNT = LPT(4) - CHCNT
      IF (CHAR .EQ. EOL) CHCNT = CHCNT+1
      SYV = SYV + S/10.0D0**CHCNT
   60 IF (CHAR.NE.D .AND. CHAR.NE.E) GO TO 70
      CALL GETCH
      SIGN = CHAR
      IF (SIGN.EQ.MINUS .OR. SIGN.EQ.PLUS) CALL GETCH
      CALL GETVAL(S)
      IF (SIGN .NE. MINUS) SYV = SYV*10.0D0**S
      IF (SIGN .EQ. MINUS) SYV = SYV/10.0D0**S
   70 STKI(VSIZE) = FLOP(SYV)
      SYM = NUM
C
   90 IF (CHAR .NE. BLANK) GO TO 99
      CALL GETCH
      GO TO 90
   99 IF (DDT .NE. 1) RETURN
      IF (SYM.GT.NAME .AND. SYM.LT.ALFL) WRITE(WTE,197) ALFA(SYM+1)
      IF (SYM .GE. ALFL) WRITE(WTE,198)
      IF (SYM .EQ. NAME) CALL PRNTID(SYN,1)
      IF (SYM .EQ. NUM) WRITE(WTE,199) SYV
  197 FORMAT(1X,A1)
  198 FORMAT(1X,'EOL')
  199 FORMAT(1X,G8.2)
      RETURN
      END

      SUBROUTINE GETVAL(S)
      DOUBLE PRECISION S
C     FORM NUMERICAL VALUE
      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
      S = 0.0D0
   10 IF (CHAR .GT. 9) RETURN
      S = 10.0D0*S + CHAR
      CALL GETCH
      GO TO 10
      END

      SUBROUTINE MATFN1
C
C     EVALUATE FUNCTIONS INVOLVING GAUSSIAN ELIMINATION
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
      DOUBLE PRECISION DTR(2),DTI(2),SR,SI,RCOND,T,T0,T1,FLOP,EPS,WASUM
C
      IF (DDT .EQ. 1) WRITE(WTE,100) FIN
  100 FORMAT(1X,'MATFN1',I4)
C
      L = LSTK(TOP)
      M = MSTK(TOP)
      N = NSTK(TOP)
      IF (FIN .EQ. -1) GO TO 10
      IF (FIN .EQ. -2) GO TO 20
      GO TO (30,40,50,60,70,80,85),FIN
C
C     MATRIX RIGHT DIVISION, A/A2
   10 L2 = LSTK(TOP+1)
      M2 = MSTK(TOP+1)
      N2 = NSTK(TOP+1)
      IF (M2 .NE. N2) CALL ERROR(20)
      IF (ERR .GT. 0) RETURN
      IF (M*N .EQ. 1) GO TO 16
      IF (N .NE. N2) CALL ERROR(11)
      IF (ERR .GT. 0) RETURN
      L3 = L2 + M2*N2
      ERR = L3+N2 - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      CALL WGECO(STKR(L2),STKI(L2),M2,N2,BUF,RCOND,STKR(L3),STKI(L3))
      IF (RCOND .EQ. 0.0D0) CALL ERROR(19)
      IF (ERR .GT. 0) RETURN
      T = FLOP(1.0D0 + RCOND)
      IF (T.EQ.1.0D0 .AND. FUN.NE.21) WRITE(WTE,11) RCOND
      IF (T.EQ.1.0D0 .AND. FUN.NE.21 .AND. WIO.NE.0) WRITE(WIO,11) RCOND
   11 FORMAT(1X,'WARNING.'
     $  /1X,'MATRIX IS CLOSE TO SINGULAR OR BADLY SCALED.'
     $  /1X,'RESULTS MAY BE INACCURATE.  RCOND =', 1PD13.4/)
      IF (T.EQ.1.0D0 .AND. FUN.EQ.21) WRITE(WTE,12) RCOND
      IF (T.EQ.1.0D0 .AND. FUN.EQ.21 .AND. WIO.NE.0) WRITE(WIO,12) RCOND
   12 FORMAT(1X,'WARNING.'
     $  /1X,'EIGENVECTORS ARE BADLY CONDITIONED.'
     $  /1X,'RESULTS MAY BE INACCURATE.  RCOND =', 1PD13.4/)
      DO 15 I = 1, M
         DO 13 J = 1, N
            LS = L+I-1+(J-1)*M
            LL = L3+J-1
            STKR(LL) = STKR(LS)
            STKI(LL) = -STKI(LS)
   13    CONTINUE
         CALL WGESL(STKR(L2),STKI(L2),M2,N2,BUF,STKR(L3),STKI(L3),1)
         DO 14 J = 1, N
            LL = L+I-1+(J-1)*M
            LS = L3+J-1
            STKR(LL) = STKR(LS)
            STKI(LL) = -STKI(LS)
   14    CONTINUE
   15 CONTINUE
      IF (FUN .NE. 21) GO TO 99
C
C     CHECK FOR IMAGINARY ROUNDOFF IN MATRIX FUNCTIONS
      SR = WASUM(N*N,STKR(L),STKR(L),1)
      SI = WASUM(N*N,STKI(L),STKI(L),1)
      EPS = STKR(VSIZE-4)
      T = EPS*SR
      IF (DDT .EQ. 18) WRITE(WTE,115) SR,SI,EPS,T
  115 FORMAT(1X,'SR,SI,EPS,T',1P4D13.4)
      IF (SI .LE. EPS*SR) CALL RSET(N*N,0.0D0,STKI(L),1)
      GO TO 99
C
   16 SR = STKR(L)
      SI = STKI(L)
      N = N2
      M = N
      MSTK(TOP) = N
      NSTK(TOP) = N
      CALL WCOPY(N*N,STKR(L2),STKI(L2),1,STKR(L),STKI(L),1)
      GO TO 30
C
C     MATRIX LEFT DIVISION A BACKSLASH A2
   20 L2 = LSTK(TOP+1)
      M2 = MSTK(TOP+1)
      N2 = NSTK(TOP+1)
      IF (M .NE. N) CALL ERROR(20)
      IF (ERR .GT. 0) RETURN
      IF (M2*N2 .EQ. 1) GO TO 26
      L3 = L2 + M2*N2
      ERR = L3+N - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      CALL WGECO(STKR(L),STKI(L),M,N,BUF,RCOND,STKR(L3),STKI(L3))
      IF (RCOND .EQ. 0.0D0) CALL ERROR(19)
      IF (ERR .GT. 0) RETURN
      T = FLOP(1.0D0 + RCOND)
      IF (T .EQ. 1.0D0) WRITE(WTE,11) RCOND
      IF (T.EQ.1.0D0 .AND. WIO.NE.0) WRITE(WIO,11) RCOND
      IF (M2 .NE. N) CALL ERROR(12)
      IF (ERR .GT. 0) RETURN
      DO 23 J = 1, N2
         LJ = L2+(J-1)*M2
         CALL WGESL(STKR(L),STKI(L),M,N,BUF,STKR(LJ),STKI(LJ),0)
   23 CONTINUE
      NSTK(TOP) = N2
      CALL WCOPY(M2*N2,STKR(L2),STKI(L2),1,STKR(L),STKI(L),1)
      GO TO 99
   26 SR = STKR(L2)
      SI = STKI(L2)
      GO TO 30
C
C     INV
C
   30 IF (M .NE. N) CALL ERROR(20)
      IF (ERR .GT. 0) RETURN
      IF (DDT .EQ. 17) GO TO 32
      DO 31 J = 1, N
      DO 31 I = 1, N
        LS = L+I-1+(J-1)*N
        T0 = STKR(LS)
        T1 = FLOP(1.0D0/(DFLOAT(I+J-1)))
        IF (T0 .NE. T1) GO TO 32
   31 CONTINUE
      GO TO 72
   32 L3 = L + N*N
      ERR = L3+N - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      CALL WGECO(STKR(L),STKI(L),M,N,BUF,RCOND,STKR(L3),STKI(L3))
      IF (RCOND .EQ. 0.0D0) CALL ERROR(19)
      IF (ERR .GT. 0) RETURN
      T = FLOP(1.0D0 + RCOND)
      IF (T .EQ. 1.0D0) WRITE(WTE,11) RCOND
      IF (T.EQ.1.0D0 .AND. WIO.NE.0) WRITE(WIO,11) RCOND
      CALL WGEDI(STKR(L),STKI(L),M,N,BUF,DTR,DTI,STKR(L3),STKI(L3),1)
      IF (FIN .LT. 0) CALL WSCAL(N*N,SR,SI,STKR(L),STKI(L),1)
      GO TO 99
C
C     DET
C
   40 IF (M .NE. N) CALL ERROR(20)
      IF (ERR .GT. 0) RETURN
      CALL WGEFA(STKR(L),STKI(L),M,N,BUF,INFO)
      CALL WGEDI(STKR(L),STKI(L),M,N,BUF,DTR,DTI,SR,SI,10)
      K = IDINT(DTR(2))
      KA = IABS(K)+2
      T = 1.0D0
      DO 41 I = 1, KA
         T = T/10.0D0
         IF (T .EQ. 0.0D0) GO TO 42
   41 CONTINUE
      STKR(L) = DTR(1)*10.D0**K
      STKI(L) = DTI(1)*10.D0**K
      MSTK(TOP) = 1
      NSTK(TOP) = 1
      GO TO 99
   42 IF (DTI(1) .EQ. 0.0D0) WRITE(WTE,43) DTR(1),K
      IF (DTI(1) .NE. 0.0D0) WRITE(WTE,44) DTR(1),DTI(1),K
   43 FORMAT(1X,'DET =  ',F7.4,7H * 10**,I4)
   44 FORMAT(1X,'DET =  ',F7.4,' + ',F7.4,' i ',7H * 10**,I4)
      STKR(L) = DTR(1)
      STKI(L) = DTI(1)
      STKR(L+1) = DTR(2)
      STKI(L+1) = 0.0D0
      MSTK(TOP) = 1
      NSTK(TOP) = 2
      GO TO 99
C
C     RCOND
C
   50 IF (M .NE. N) CALL ERROR(20)
      IF (ERR .GT. 0) RETURN
      L3 = L + N*N
      ERR = L3+N - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      CALL WGECO(STKR(L),STKI(L),M,N,BUF,RCOND,STKR(L3),STKI(L3))
      STKR(L) = RCOND
      STKI(L) = 0.0D0
      MSTK(TOP) = 1
      NSTK(TOP) = 1
      IF (LHS .EQ. 1) GO TO 99
      L = L + 1
      CALL WCOPY(N,STKR(L3),STKI(L3),1,STKR(L),STKI(L),1)
      TOP = TOP + 1
      LSTK(TOP) = L
      MSTK(TOP) = N
      NSTK(TOP) = 1
      GO TO 99
C
C     LU
C
   60 IF (M .NE. N) CALL ERROR(20)
      IF (ERR .GT. 0) RETURN
      CALL WGEFA(STKR(L),STKI(L),M,N,BUF,INFO)
      IF (LHS .NE. 2) GO TO 99
      NN = N*N
      IF (TOP+1 .GE. BOT) CALL ERROR(18)
      IF (ERR .GT. 0) RETURN
      TOP = TOP+1
      LSTK(TOP) = L + NN
      MSTK(TOP) = N
      NSTK(TOP) = N
      ERR = L+NN+NN - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      DO 64 KB = 1, N
        K = N+1-KB
        DO 61 I = 1, N
          LL = L+I-1+(K-1)*N
          LU = LL + NN
          IF (I .LE. K) STKR(LU) = STKR(LL)
          IF (I .LE. K) STKI(LU) = STKI(LL)
          IF (I .GT. K) STKR(LU) = 0.0D0
          IF (I .GT. K) STKI(LU) = 0.0D0
          IF (I .LT. K) STKR(LL) = 0.0D0
          IF (I .LT. K) STKI(LL) = 0.0D0
          IF (I .EQ. K) STKR(LL) = 1.0D0
          IF (I .EQ. K) STKI(LL) = 0.0D0
          IF (I .GT. K) STKR(LL) = -STKR(LL)
          IF (I .GT. K) STKI(LL) = -STKI(LL)
   61   CONTINUE
        I = BUF(K)
        IF (I .EQ. K) GO TO 64
        LI = L+I-1+(K-1)*N
        LK = L+K-1+(K-1)*N
        CALL WSWAP(N-K+1,STKR(LI),STKI(LI),N,STKR(LK),STKI(LK),N)
   64 CONTINUE
      GO TO 99
C
C     HILBERT
   70 N = IDINT(STKR(L))
      MSTK(TOP) = N
      NSTK(TOP) = N
   72 CALL HILBER(STKR(L),N,N)
      CALL RSET(N*N,0.0D0,STKI(L),1)
      IF (FIN .LT. 0) CALL WSCAL(N*N,SR,SI,STKR(L),STKI(L),1)
      GO TO 99
C
C     CHOLESKY
   80 IF (M .NE. N) CALL ERROR(20)
      IF (ERR .GT. 0) RETURN
      CALL WPOFA(STKR(L),STKI(L),M,N,ERR)
      IF (ERR .NE. 0) CALL ERROR(29)
      IF (ERR .GT. 0) RETURN
      DO 81 J = 1, N
        LL = L+J+(J-1)*M
        CALL WSET(M-J,0.0D0,0.0D0,STKR(LL),STKI(LL),1)
   81 CONTINUE
      GO TO 99
C
C     RREF
   85 IF (RHS .LT. 2) GO TO 86
        TOP = TOP-1
        L = LSTK(TOP)
        IF (MSTK(TOP) .NE. M) CALL ERROR(5)
        IF (ERR .GT. 0) RETURN
        N = N + NSTK(TOP)
   86 CALL RREF(STKR(L),STKI(L),M,M,N,STKR(VSIZE-4))
      NSTK(TOP) = N
      GO TO 99
C
   99 RETURN
      END

         SUBROUTINE MATFN2
C
C     EVALUATE ELEMENTARY FUNCTIONS AND FUNCTIONS INVOLVING
C     EIGENVALUES AND EIGENVECTORS
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
      DOUBLE PRECISION PYTHAG,ROUND,TR,TI,SR,SI,POWR,POWI,FLOP
      LOGICAL HERM,SCHUR,VECT,HESS
C
      IF (DDT .EQ. 1) WRITE(WTE,100) FIN
  100 FORMAT(1X,'MATFN2',I4)
C
C     FUNCTIONS/FIN
C     **   SIN  COS ATAN  EXP  SQRT LOG
C      0    1    2    3    4    5    6
C    EIG  SCHU HESS POLY ROOT
C     11   12   13   14   15
C    ABS  ROUN REAL IMAG CONJ
C     21   22   23   24   25
      IF (FIN .NE. 0) GO TO 05
         L = LSTK(TOP+1)
         POWR = STKR(L)
         POWI = STKI(L)
   05 L = LSTK(TOP)
      M = MSTK(TOP)
      N = NSTK(TOP)
      IF (FIN .GE. 11 .AND. FIN .LE. 13) GO TO 10
      IF (FIN .EQ. 14 .AND. (M.EQ.1 .OR. N.EQ.1)) GO TO 50
      IF (FIN .EQ. 14) GO TO 10
      IF (FIN .EQ. 15) GO TO 60
      IF (FIN .GT. 20) GO TO 40
      IF (M .EQ. 1 .OR. N .EQ. 1) GO TO 40
C
C     EIGENVALUES AND VECTORS
   10 IF (M .NE. N) CALL ERROR(20)
      IF (ERR .GT. 0) RETURN
      SCHUR = FIN .EQ. 12
      HESS = FIN .EQ. 13
      VECT = LHS.EQ.2 .OR. FIN.LT.10
      NN = N*N
      L2 = L + NN
      LD = L2 + NN
      LE = LD + N
      LW = LE + N
      ERR = LW+N - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      CALL WCOPY(NN,STKR(L),STKI(L),1,STKR(L2),STKI(L2),1)
C
C     CHECK IF HERMITIAN
      DO 15 J = 1, N
      DO 15 I = 1, J
         LS = L+I-1+(J-1)*N
         LL = L+(I-1)*N+J-1
         HERM = STKR(LL).EQ.STKR(LS) .AND. STKI(LL).EQ.-STKI(LS)
         IF (.NOT. HERM) GO TO 30
   15 CONTINUE
C
C     HERMITIAN EIGENVALUE PROBLEM
      CALL WSET(NN,0.0D0,0.0D0,STKR(L),STKI(L),1)
      CALL WSET(N,1.0D0,0.0D0,STKR(L),STKI(L),N+1)
      CALL WSET(N,0.0D0,0.0D0,STKI(LD),STKI(LE),1)
      JOB = 0
      IF (VECT) JOB = 1
      CALL HTRIDI(N,N,STKR(L2),STKI(L2),STKR(LD),STKR(LE),
     $            STKR(LE),STKR(LW))
      IF (.NOT.HESS) CALL IMTQL2(N,N,STKR(LD),STKR(LE),STKR(L),ERR,JOB)
      IF (ERR .GT. 0) CALL ERROR(24)
      IF (ERR .GT. 0) RETURN
      IF (JOB .NE. 0)
     $  CALL HTRIBK(N,N,STKR(L2),STKI(L2),STKR(LW),N,STKR(L),STKI(L))
      GO TO 31
C
C     NON-HERMITIAN EIGENVALUE PROBLEM
   30 CALL CORTH(N,N,1,N,STKR(L2),STKI(L2),STKR(LW),STKI(LW))
      IF (.NOT.VECT .AND. HESS) GO TO 31
      JOB = 0
      IF (VECT) JOB = 2
      IF (VECT .AND. SCHUR) JOB = 1
      IF (HESS) JOB = 3
      CALL COMQR3(N,N,1,N,STKR(LW),STKI(LW),STKR(L2),STKI(L2),
     $            STKR(LD),STKI(LD),STKR(L),STKI(L),ERR,JOB)
      IF (ERR .GT. 0) CALL ERROR(24)
      IF (ERR .GT. 0) RETURN
C
C     VECTORS
   31 IF (.NOT.VECT) GO TO 34
      IF (TOP+1 .GE. BOT) CALL ERROR(18)
      IF (ERR .GT. 0) RETURN
      TOP = TOP+1
      LSTK(TOP) = L2
      MSTK(TOP) = N
      NSTK(TOP) = N
C
C     DIAGONAL OF VALUES OR CANONICAL FORMS
   34 IF (.NOT.VECT .AND. .NOT.SCHUR .AND. .NOT.HESS) GO TO 37
      DO 36 J = 1, N
         LJ = L2+(J-1)*N
         IF (SCHUR .AND. (.NOT.HERM)) LJ = LJ+J
         IF (HESS .AND. (.NOT.HERM)) LJ = LJ+J+1
         LL = L2+J*N-LJ
         CALL WSET(LL,0.0D0,0.0D0,STKR(LJ),STKI(LJ),1)
   36 CONTINUE
      IF (.NOT.HESS .OR. HERM)
     $   CALL WCOPY(N,STKR(LD),STKI(LD),1,STKR(L2),STKI(L2),N+1)
      LL = L2+1
      IF (HESS .AND. HERM)
     $   CALL WCOPY(N-1,STKR(LE+1),STKI(LE+1),1,STKR(LL),STKI(LL),N+1)
      LL = L2+N
      IF (HESS .AND. HERM)
     $   CALL WCOPY(N-1,STKR(LE+1),STKI(LE+1),1,STKR(LL),STKI(LL),N+1)
      IF (FIN .LT. 10) GO TO 42
      IF (VECT .OR. .NOT.(SCHUR.OR.HESS)) GO TO 99
      CALL WCOPY(NN,STKR(L2),STKI(L2),1,STKR(L),STKI(L),1)
      GO TO 99
C
C     VECTOR OF EIGENVALUES
   37 IF (FIN .EQ. 14) GO TO 52
      CALL WCOPY(N,STKR(LD),STKI(LD),1,STKR(L),STKI(L),1)
      NSTK(TOP) = 1
      GO TO 99
C
C     ELEMENTARY FUNCTIONS
C     FOR MATRICES.. X,D = EIG(A), FUN(A) = X*FUN(D)/X
   40 INC = 1
      N = M*N
      L2 = L
      GO TO 44
   42 INC = N+1
   44 DO 46 J = 1, N
        LS = L2+(J-1)*INC
        SR = STKR(LS)
        SI = STKI(LS)
        TI = 0.0D0
        IF (FIN .NE. 0) GO TO 45
          CALL WLOG(SR,SI,SR,SI)
          CALL WMUL(SR,SI,POWR,POWI,SR,SI)
          TR = DEXP(SR)*DCOS(SI)
          TI = DEXP(SR)*DSIN(SI)
   45   IF (FIN .EQ. 1) TR = DSIN(SR)*DCOSH(SI)
        IF (FIN .EQ. 1) TI = DCOS(SR)*DSINH(SI)
        IF (FIN .EQ. 2) TR = DCOS(SR)*DCOSH(SI)
        IF (FIN .EQ. 2) TI = -DSIN(SR)*DSINH(SI)
        IF (FIN .EQ. 3) CALL WATAN(SR,SI,TR,TI)
        IF (FIN .EQ. 4) TR = DEXP(SR)*DCOS(SI)
        IF (FIN .EQ. 4) TI = DEXP(SR)*DSIN(SI)
        IF (FIN .EQ. 5) CALL WSQRT(SR,SI,TR,TI)
        IF (FIN .EQ. 6) CALL WLOG(SR,SI,TR,TI)
        IF (FIN .EQ. 21) TR = PYTHAG(SR,SI)
        IF (FIN .EQ. 22) TR = ROUND(SR)
        IF (FIN .EQ. 23) TR = SR
        IF (FIN .EQ. 24) TR = SI
        IF (FIN .EQ. 25) TR = SR
        IF (FIN .EQ. 25) TI = -SI
        IF (ERR .GT. 0) RETURN
        STKR(LS) = FLOP(TR)
        STKI(LS) = 0.0D0
        IF (TI .NE. 0.0D0) STKI(LS) = FLOP(TI)
   46 CONTINUE
      IF (INC .EQ. 1) GO TO 99
      DO 48 J = 1, N
        LS = L2+(J-1)*INC
        SR = STKR(LS)
        SI = STKI(LS)
        LS = L+(J-1)*N
        LL = L2+(J-1)*N
        CALL WCOPY(N,STKR(LS),STKI(LS),1,STKR(LL),STKI(LL),1)
        CALL WSCAL(N,SR,SI,STKR(LS),STKI(LS),1)
   48 CONTINUE
C     SIGNAL MATFN1 TO DIVIDE BY EIGENVECTORS
      FUN = 21
      FIN = -1
      TOP = TOP-1
      GO TO 99
C
C     POLY
C     FORM POLYNOMIAL WITH GIVEN VECTOR AS ROOTS
   50 N = MAX0(M,N)
      LD = L+N+1
      CALL WCOPY(N,STKR(L),STKI(L),1,STKR(LD),STKI(LD),1)
C
C     FORM CHARACTERISTIC POLYNOMIAL
   52 CALL WSET(N+1,0.0D0,0.0D0,STKR(L),STKI(L),1)
      STKR(L) = 1.0D0
      DO 56 J = 1, N
         CALL WAXPY(J,-STKR(LD),-STKI(LD),STKR(L),STKI(L),-1,
     $              STKR(L+1),STKI(L+1),-1)
         LD = LD+1
   56 CONTINUE
      MSTK(TOP) = N+1
      NSTK(TOP) = 1
      GO TO 99
C
C     ROOTS
   60 LL = L+M*N
      STKR(LL) = -1.0D0
      STKI(LL) = 0.0D0
      K = -1
   61 K = K+1
      L1 = L+K
      IF (DABS(STKR(L1))+DABS(STKI(L1)) .EQ. 0.0D0) GO TO 61
      N = MAX0(M*N - K-1, 0)
      IF (N .LE. 0) GO TO 65
      L2 = L1+N+1
      LW = L2+N*N
      ERR = LW+N - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      CALL WSET(N*N+N,0.0D0,0.0D0,STKR(L2),STKI(L2),1)
      DO 64 J = 1, N
         LL = L2+J+(J-1)*N
         STKR(LL) = 1.0D0
         LS = L1+J
         LL = L2+(J-1)*N
         CALL WDIV(-STKR(LS),-STKI(LS),STKR(L1),STKI(L1),
     $             STKR(LL),STKI(LL))
         IF (ERR .GT. 0) RETURN
   64 CONTINUE
      CALL COMQR3(N,N,1,N,STKR(LW),STKI(LW),STKR(L2),STKI(L2),
     $            STKR(L),STKI(L),TR,TI,ERR,0)
      IF (ERR .GT. 0) CALL ERROR(24)
      IF (ERR .GT. 0) RETURN
   65 MSTK(TOP) = N
      NSTK(TOP) = 1
      GO TO 99
   99 RETURN
      END

      SUBROUTINE MATFN3
C
C     EVALUATE FUNCTIONS INVOLVING SINGULAR VALUE DECOMPOSITION
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 FRO,INF
      DOUBLE PRECISION P,S,T,TOL,EPS
      DOUBLE PRECISION WDOTCR,WDOTCI,PYTHAG,WNRM2,WASUM,FLOP
C
      IF (DDT .EQ. 1) WRITE(WTE,100) FIN
  100 FORMAT(1X,'MATFN3',I4)
C
      IF (FIN.EQ.1 .AND. RHS.EQ.2) TOP = TOP-1
      L = LSTK(TOP)
      M = MSTK(TOP)
      N = NSTK(TOP)
      MN = M*N
      GO TO (50,70,10,30,70), FIN
C
C     COND
C
   10 LD = L + M*N
      L1 = LD + MIN0(M+1,N)
      L2 = L1 + N
      ERR = L2+MIN0(M,N) - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      CALL WSVDC(STKR(L),STKI(L),M,M,N,STKR(LD),STKI(LD),
     $           STKR(L1),STKI(L1),T,T,1,T,T,1,STKR(L2),STKI(L2),
     $           0,ERR)
      IF (ERR .NE. 0) CALL ERROR(24)
      IF (ERR .GT. 0) RETURN
      S = STKR(LD)
      LD = LD + MIN0(M,N) - 1
      T = STKR(LD)
      IF (T .EQ. 0.0D0) GO TO 13
      STKR(L) = FLOP(S/T)
      STKI(L) = 0.0D0
      MSTK(TOP) = 1
      NSTK(TOP) = 1
      GO TO 99
   13 WRITE(WTE,14)
      IF (WIO .NE. 0) WRITE(WIO,14)
   14 FORMAT(1X,'CONDITION IS INFINITE')
      MSTK(TOP) = 0
      GO TO 99
C
C     NORM
C
   30 P = 2.0D0
      INF = .FALSE.
      IF (RHS .NE. 2) GO TO 31
      FRO = IDINT(STKR(L)).EQ.15 .AND. MN.GT.1
      INF = IDINT(STKR(L)).EQ.18 .AND. MN.GT.1
      IF (.NOT. FRO) P = STKR(L)
      TOP = TOP-1
      L = LSTK(TOP)
      M = MSTK(TOP)
      N = NSTK(TOP)
      MN = M*N
      IF (FRO) M = MN
      IF (FRO) N = 1
   31 IF (M .GT. 1 .AND. N .GT. 1) GO TO 40
      IF (P .EQ. 1.0D0) GO TO 36
      IF (P .EQ. 2.0D0) GO TO 38
      I = IWAMAX(MN,STKR(L),STKI(L),1) + L - 1
      S = DABS(STKR(I)) + DABS(STKI(I))
      IF (INF .OR. S .EQ. 0.0D0) GO TO 49
      T = 0.0D0
      DO 33 I = 1, MN
         LS = L+I-1
         T = FLOP(T + (PYTHAG(STKR(LS),STKI(LS))/S)**P)
   33 CONTINUE
      IF (P .NE. 0.0D0) P = 1.0D0/P
      S = FLOP(S*T**P)
      GO TO 49
   36 S = WASUM(MN,STKR(L),STKI(L),1)
      GO TO 49
   38 S = WNRM2(MN,STKR(L),STKI(L),1)
      GO TO 49
C
C     MATRIX NORM
C
   40 IF (INF) GO TO 43
      IF (P .EQ. 1.0D0) GO TO 46
      IF (P .NE. 2.0D0) CALL ERROR(23)
      IF (ERR .GT. 0) RETURN
      LD = L + M*N
      L1 = LD + MIN0(M+1,N)
      L2 = L1 + N
      ERR = L2+MIN0(M,N) - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      CALL WSVDC(STKR(L),STKI(L),M,M,N,STKR(LD),STKI(LD),
     $           STKR(L1),STKI(L1),T,T,1,T,T,1,STKR(L2),STKI(L2),
     $           0,ERR)
      IF (ERR .NE. 0) CALL ERROR(24)
      IF (ERR .GT. 0) RETURN
      S = STKR(LD)
      GO TO 49
   43 S = 0.0D0
      DO 45 I = 1, M
         LI = L+I-1
         T = WASUM(N,STKR(LI),STKI(LI),M)
         S = DMAX1(S,T)
   45 CONTINUE
      GO TO 49
   46 S = 0.0D0
      DO 48 J = 1, N
         LJ = L+(J-1)*M
         T = WASUM(M,STKR(LJ),STKI(LJ),1)
         S = DMAX1(S,T)
   48 CONTINUE
      GO TO 49
   49 STKR(L) = S
      STKI(L) = 0.0D0
      MSTK(TOP) = 1
      NSTK(TOP) = 1
      GO TO 99
C
C     SVD
C
   50 IF (LHS .NE. 3) GO TO 52
      K = M
      IF (RHS .EQ. 2) K = MIN0(M,N)
      LU = L + M*N
      LD = LU + M*K
      LV = LD + K*N
      L1 = LV + N*N
      L2 = L1 + N
      ERR = L2+MIN0(M,N) - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      JOB = 11
      IF (RHS .EQ. 2) JOB = 21
      CALL WSVDC(STKR(L),STKI(L),M,M,N,STKR(LD),STKI(LD),
     $        STKR(L1),STKI(L1),STKR(LU),STKI(LU),M,STKR(LV),STKI(LV),
     $        N,STKR(L2),STKI(L2),JOB,ERR)
      DO 51 JB = 1, N
      DO 51 I = 1, K
        J = N+1-JB
        LL = LD+I-1+(J-1)*K
        IF (I.NE.J) STKR(LL) = 0.0D0
        STKI(LL) = 0.0D0
        LS = LD+I-1
        IF (I.EQ.J) STKR(LL) = STKR(LS)
        LS = L1+I-1
        IF (ERR.NE.0 .AND. I.EQ.J-1) STKR(LL) = STKR(LS)
   51 CONTINUE
      IF (ERR .NE. 0) CALL ERROR(24)
      ERR = 0
      CALL WCOPY(M*K+K*N+N*N,STKR(LU),STKI(LU),1,STKR(L),STKI(L),1)
      MSTK(TOP) = M
      NSTK(TOP) = K
      IF (TOP+1 .GE. BOT) CALL ERROR(18)
      IF (ERR .GT. 0) RETURN
      TOP = TOP+1
      LSTK(TOP) = L + M*K
      MSTK(TOP) = K
      NSTK(TOP) = N
      IF (TOP+1 .GE. BOT) CALL ERROR(18)
      IF (ERR .GT. 0) RETURN
      TOP = TOP+1
      LSTK(TOP) = L + M*K + K*N
      MSTK(TOP) = N
      NSTK(TOP) = N
      GO TO 99
C
   52 LD = L + M*N
      L1 = LD + MIN0(M+1,N)
      L2 = L1 + N
      ERR = L2+MIN0(M,N) - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      CALL WSVDC(STKR(L),STKI(L),M,M,N,STKR(LD),STKI(LD),
     $           STKR(L1),STKI(L1),T,T,1,T,T,1,STKR(L2),STKI(L2),
     $           0,ERR)
      IF (ERR .NE. 0) CALL ERROR(24)
      IF (ERR .GT. 0) RETURN
      K = MIN0(M,N)
      CALL WCOPY(K,STKR(LD),STKI(LD),1,STKR(L),STKI(L),1)
      MSTK(TOP) = K
      NSTK(TOP) = 1
      GO TO 99
C
C     PINV AND RANK
C
   70 TOL = -1.0D0
      IF (RHS .NE. 2) GO TO 71
      TOL = STKR(L)
      TOP = TOP-1
      L = LSTK(TOP)
      M = MSTK(TOP)
      N = NSTK(TOP)
   71 LU = L + M*N
      LD = LU + M*M
      IF (FIN .EQ. 5) LD = L + M*N
      LV = LD + M*N
      L1 = LV + N*N
      IF (FIN .EQ. 5) L1 = LD + N
      L2 = L1 + N
      ERR = L2+MIN0(M,N) - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      IF (FIN .EQ. 2) JOB = 11
      IF (FIN .EQ. 5) JOB = 0
      CALL WSVDC(STKR(L),STKI(L),M,M,N,STKR(LD),STKI(LD),
     $        STKR(L1),STKI(L1),STKR(LU),STKI(LU),M,STKR(LV),STKI(LV),
     $        N,STKR(L2),STKI(L2),JOB,ERR)
      IF (ERR .NE. 0) CALL ERROR(24)
      IF (ERR .GT. 0) RETURN
      EPS = STKR(VSIZE-4)
      IF (TOL .LT. 0.0D0) TOL = FLOP(DFLOAT(MAX0(M,N))*EPS*STKR(LD))
      MN = MIN0(M,N)
      K = 0
      DO 72 J = 1, MN
        LS = LD+J-1
        S = STKR(LS)
        IF (S .LE. TOL) GO TO 73
        K = J
        LL = LV+(J-1)*N
        IF (FIN .EQ. 2) CALL WRSCAL(N,1.0D0/S,STKR(LL),STKI(LL),1)
   72 CONTINUE
   73 IF (FIN .EQ. 5) GO TO 78
      DO 76 J = 1, M
      DO 76 I = 1, N
        LL = L+I-1+(J-1)*N
        L1 = LV+I-1
        L2 = LU+J-1
        STKR(LL) = WDOTCR(K,STKR(L2),STKI(L2),M,STKR(L1),STKI(L1),N)
        STKI(LL) = WDOTCI(K,STKR(L2),STKI(L2),M,STKR(L1),STKI(L1),N)
   76 CONTINUE
      MSTK(TOP) = N
      NSTK(TOP) = M
      GO TO 99
   78 STKR(L) = DFLOAT(K)
      STKI(L) = 0.0D0
      MSTK(TOP) = 1
      NSTK(TOP) = 1
      GO TO 99
C
   99 RETURN
      END

      SUBROUTINE MATFN4
C
C     EVALUATE FUNCTIONS INVOLVING QR DECOMPOSITION (LEAST SQUARES)
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
      DOUBLE PRECISION T,TOL,EPS,FLOP
      INTEGER QUOTE
      DATA QUOTE/49/
C
      IF (DDT .EQ. 1) WRITE(WTE,100) FIN
  100 FORMAT(1X,'MATFN4',I4)
C
      L = LSTK(TOP)
      M = MSTK(TOP)
      N = NSTK(TOP)
      IF (FIN .EQ. -1) GO TO 10
      IF (FIN .EQ. -2) GO TO 20
      GO TO 40
C
C     RECTANGULAR MATRIX RIGHT DIVISION, A/A2
   10 L2 = LSTK(TOP+1)
      M2 = MSTK(TOP+1)
      N2 = NSTK(TOP+1)
      TOP = TOP + 1
      IF (N.GT.1 .AND. N.NE.N2) CALL ERROR(11)
      IF (ERR .GT. 0) RETURN
      CALL STACK1(QUOTE)
      IF (ERR .GT. 0) RETURN
      LL = L2+M2*N2
      CALL WCOPY(M*N,STKR(L),STKI(L),1,STKR(LL),STKI(LL),1)
      CALL WCOPY(M*N+M2*N2,STKR(L2),STKI(L2),1,STKR(L),STKI(L),1)
      LSTK(TOP) = L+M2*N2
      MSTK(TOP) = M
      NSTK(TOP) = N
      CALL STACK1(QUOTE)
      IF (ERR .GT. 0) RETURN
      TOP = TOP - 1
      M = N2
      N = M2
      GO TO 20
C
C     RECTANGULAR MATRIX LEFT DIVISION A BACKSLASH A2
C
   20 L2 = LSTK(TOP+1)
      M2 = MSTK(TOP+1)
      N2 = NSTK(TOP+1)
      IF (M2*N2 .GT. 1) GO TO 21
        M2 = M
        N2 = M
        ERR = L2+M*M - LSTK(BOT)
        IF (ERR .GT. 0) CALL ERROR(17)
        IF (ERR .GT. 0) RETURN
        CALL WSET(M*M-1,0.0D0,0.0D0,STKR(L2+1),STKI(L2+1),1)
        CALL WCOPY(M,STKR(L2),STKI(L2),0,STKR(L2),STKI(L2),M+1)
   21 IF (M2 .NE. M) CALL ERROR(12)
      IF (ERR .GT. 0) RETURN
      L3 = L2 + MAX0(M,N)*N2
      L4 = L3 + N
      ERR = L4 + N - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      IF (M .GT. N) GO TO 23
      DO 22 JB = 1, N2
        J = N+1-JB
        LS = L2 + (J-1)*M
        LL = L2 + (J-1)*N
        CALL WCOPY(M,STKR(LS),STKI(LS),-1,STKR(LL),STKI(LL),-1)
   22 CONTINUE
   23 DO 24 J = 1, N
        BUF(J) = 0
   24 CONTINUE
      CALL WQRDC(STKR(L),STKI(L),M,M,N,STKR(L4),STKI(L4),
     $           BUF,STKR(L3),STKI(L3),1)
      K = 0
      EPS = STKR(VSIZE-4)
      T = DABS(STKR(L))+DABS(STKI(L))
      TOL = FLOP(DFLOAT(MAX0(M,N))*EPS*T)
      MN = MIN0(M,N)
      DO 27 J = 1, MN
        LS = L+J-1+(J-1)*M
        T = DABS(STKR(LS)) + DABS(STKI(LS))
        IF (T .GT. TOL) K = J
   27 CONTINUE
      IF (K .LT. MN) WRITE(WTE,28) K,TOL
      IF (K.LT.MN .AND. WIO.NE.0) WRITE(WIO,28) K,TOL
   28 FORMAT(1X,'RANK DEFICIENT,  RANK =',I4,',  TOL =',1PD13.4)
      MN = MAX0(M,N)
      DO 29 J = 1, N2
        LS = L2+(J-1)*MN
        CALL WQRSL(STKR(L),STKI(L),M,M,K,STKR(L4),STKI(L4),
     $             STKR(LS),STKI(LS),T,T,STKR(LS),STKI(LS),
     $             STKR(LS),STKI(LS),T,T,T,T,100,INFO)
        LL = LS+K
        CALL WSET(N-K,0.0D0,0.0D0,STKR(LL),STKI(LL),1)
   29 CONTINUE
      DO 31 J = 1, N
        BUF(J) = -BUF(J)
   31 CONTINUE
      DO 35 J = 1, N
        IF (BUF(J) .GT. 0) GO TO 35
        K = -BUF(J)
        BUF(J) = K
   33   CONTINUE
          IF (K .EQ. J) GO TO 34
          LS = L2+J-1
          LL = L2+K-1
          CALL WSWAP(N2,STKR(LS),STKI(LS),MN,STKR(LL),STKI(LL),MN)
          BUF(K) = -BUF(K)
          K = BUF(K)
          GO TO 33
   34   CONTINUE
   35 CONTINUE
      DO 36 J = 1, N2
        LS = L2+(J-1)*MN
        LL = L+(J-1)*N
        CALL WCOPY(N,STKR(LS),STKI(LS),1,STKR(LL),STKI(LL),1)
   36 CONTINUE
      MSTK(TOP) = N
      NSTK(TOP) = N2
      IF (FIN .EQ. -1) CALL STACK1(QUOTE)
      IF (ERR .GT. 0) RETURN
      GO TO 99
C
C     QR
C
   40 MM = MAX0(M,N)
      LS = L + MM*MM
      IF (LHS.EQ.1 .AND. FIN.EQ.1) LS = L
      LE = LS + M*N
      L4 = LE + MM
      ERR = L4+MM - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      IF (LS.NE.L) CALL WCOPY(M*N,STKR(L),STKI(L),1,STKR(LS),STKI(LS),1)
      JOB = 1
      IF (LHS.LT.3) JOB = 0
      DO 42 J = 1, N
        BUF(J) = 0
   42 CONTINUE
      CALL WQRDC(STKR(LS),STKI(LS),M,M,N,STKR(L4),STKI(L4),
     $            BUF,STKR(LE),STKI(LE),JOB)
      IF (LHS.EQ.1 .AND. FIN.EQ.1) GO TO 99
      CALL WSET(M*M,0.0D0,0.0D0,STKR(L),STKI(L),1)
      CALL WSET(M,1.0D0,0.0D0,STKR(L),STKI(L),M+1)
      DO 43 J = 1, M
        LL = L+(J-1)*M
        CALL WQRSL(STKR(LS),STKI(LS),M,M,N,STKR(L4),STKI(L4),
     $             STKR(LL),STKI(LL),STKR(LL),STKI(LL),T,T,
     $             T,T,T,T,T,T,10000,INFO)
   43 CONTINUE
      IF (FIN .EQ. 2) GO TO 99
      NSTK(TOP) = M
      DO 45 J = 1, N
        LL = LS+J+(J-1)*M
        CALL WSET(M-J,0.0D0,0.0D0,STKR(LL),STKI(LL),1)
   45 CONTINUE
      IF (TOP+1 .GE. BOT) CALL ERROR(18)
      IF (ERR .GT. 0) RETURN
      TOP = TOP+1
      LSTK(TOP) = LS
      MSTK(TOP) = M
      NSTK(TOP) = N
      IF (LHS .EQ. 2) GO TO 99
      CALL WSET(N*N,0.0D0,0.0D0,STKR(LE),STKI(LE),1)
      DO 47 J = 1, N
        LL = LE+BUF(J)-1+(J-1)*N
        STKR(LL) = 1.0D0
   47 CONTINUE
      IF (TOP+1 .GE. BOT) CALL ERROR(18)
      IF (ERR .GT. 0) RETURN
      TOP = TOP+1
      LSTK(TOP) = LE
      MSTK(TOP) = N
      NSTK(TOP) = N
      GO TO 99
C
   99 RETURN
      END
      SUBROUTINE MATFN5
C
C     FILE HANDLING AND OTHER I/O
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
      INTEGER EOL,CH,BLANK,FLAG,TOP2,PLUS,MINUS,QUOTE,SEMI,LRAT,MRAT
      INTEGER ID(4)
      DOUBLE PRECISION EPS,B,S,T,FLOP,WASUM
      LOGICAL TEXT
      DATA EOL/99/,BLANK/36/,PLUS/41/,MINUS/42/,QUOTE/49/,SEMI/39/
      DATA LRAT/5/,MRAT/100/
C
      IF (DDT .EQ. 1) WRITE(WTE,100) FIN
  100 FORMAT(1X,'MATFN5',I4)
C     FUNCTIONS/FIN
C     EXEC SAVE LOAD PRIN DIAR DISP BASE LINE CHAR PLOT RAT  DEBU
C      1    2    3    4    5    6    7    8    9   10   11   12
      L = LSTK(TOP)
      M = MSTK(TOP)
      N = NSTK(TOP)
      IF (FIN .GT. 5) GO TO 15
C
C     CONVERT FILE NAME
      MN = M*N
      FLAG = 3
      IF (SYM .EQ. SEMI) FLAG = 0
      IF (RHS .LT. 2) GO TO 12
         FLAG = IDINT(STKR(L))
         TOP2 = TOP
         TOP = TOP-1
         L = LSTK(TOP)
         MN = MSTK(TOP)*NSTK(TOP)
   12 LUN = -1
      IF (MN.EQ.1 .AND. STKR(L).LT.10.0D0) LUN = IDINT(STKR(L))
      IF (LUN .GE. 0) GO TO 15
      DO 14 J = 1, 32
         LS = L+J-1
         IF (J .LE. MN) CH = IDINT(STKR(LS))
         IF (J .GT. MN) CH = BLANK
         IF (CH.LT.0 .OR. CH.GE.ALFL) CALL ERROR(38)
         IF (ERR .GT. 0) RETURN
         IF (CASE .EQ. 0) BUF(J) = ALFA(CH+1)
         IF (CASE .EQ. 1) BUF(J) = ALFB(CH+1)
   14 CONTINUE
C
   15 GO TO (20,30,35,25,27,60,65,70,50,80,40,95),FIN
C
C     EXEC
   20 IF (LUN .EQ. 0) GO TO 23
      K = LPT(6)
      LIN(K+1) = LPT(1)
      LIN(K+2) = LPT(3)
      LIN(K+3) = LPT(6)
      LIN(K+4) = PTZ
      LIN(K+5) = RIO
      LIN(K+6) = LCT(4)
      LPT(1) = K + 7
      LCT(4) = FLAG
      PTZ = PT - 4
      IF (RIO .EQ. RTE) RIO = 12
      RIO = RIO + 1
      IF (LUN .GT. 0) RIO = LUN
      IF (LUN .LT. 0) CALL FILES(RIO,BUF)
      IF (FLAG .GE. 4) WRITE(WTE,22)
   22 FORMAT(1X,'PAUSE MODE. ENTER BLANK LINES.')
      SYM = EOL
      MSTK(TOP) = 0
      GO TO 99
C
C     EXEC(0)
   23 RIO = RTE
      ERR = 99
      GO TO 99
C
C     PRINT
   25 K = WTE
      WTE = LUN
      IF (LUN .LT. 0) WTE = 7
      IF (LUN .LT. 0) CALL FILES(WTE,BUF)
      L = LCT(2)
      LCT(2) = 9999
      IF (RHS .GT. 1) CALL PRINT(SYN,TOP2)
      LCT(2) = L
      WTE = K
      MSTK(TOP) = 0
      GO TO 99
C
C     DIARY
   27 WIO = LUN
      IF (LUN .LT. 0) WIO = 8
      IF (LUN .LT. 0) CALL FILES(WIO,BUF)
      MSTK(TOP) = 0
      GO TO 99
C
C     SAVE
   30 IF (LUN .LT. 0) LUNIT = 1
      IF (LUN .LT. 0) CALL FILES(LUNIT,BUF)
      IF (LUN .GT. 0) LUNIT = LUN
      K = LSIZE-4
      IF (K .LT. BOT) K = LSIZE
      IF (RHS .EQ. 2) K = TOP2
      IF (RHS .EQ. 2) CALL PUTID(IDSTK(1,K),SYN)
   32 L = LSTK(K)
      M = MSTK(K)
      N = NSTK(K)
      DO 34 I = 1, 4
         J = IDSTK(I,K)+1
         BUF(I) = ALFA(J)
   34 CONTINUE
      IMG = 0
      IF (WASUM(M*N,STKI(L),STKI(L),1) .NE. 0.0D0) IMG = 1
      IF(FE .EQ. 0)CALL SAVLOD(LUNIT,BUF,M,N,IMG,0,STKR(L),STKI(L))
      K = K-1
      IF (K .GE. BOT) GO TO 32
      CALL FILES(-LUNIT,BUF)
      MSTK(TOP) = 0
      GO TO 99
C
C     LOAD
   35 IF (LUN .LT. 0) LUNIT = 2
      IF (LUN .LT. 0) CALL FILES(LUNIT,BUF)
      IF (LUN .GT. 0) LUNIT = LUN
   36 JOB = LSTK(BOT) - L
      IF(FE .EQ. 0)
     +CALL SAVLOD(LUNIT,ID,MSTK(TOP),NSTK(TOP),IMG,JOB,STKR(L),STKI(L))
      MN = MSTK(TOP)*NSTK(TOP)
      IF (MN .EQ. 0) GO TO 39
      IF (IMG .EQ. 0) CALL RSET(MN,0.0D0,STKI(L),1)
      DO 38 I = 1, 4
         J = 0
   37    J = J+1
         IF (ID(I).NE.ALFA(J) .AND. J.LE.BLANK) GO TO 37
         ID(I) = J-1
   38 CONTINUE
      SYM = SEMI
      RHS = 0
      CALL STACKP(ID)
      TOP = TOP + 1
      GO TO 36
   39 CALL FILES(-LUNIT,BUF)
      MSTK(TOP) = 0
      GO TO 99
C
C     RAT
   40 IF (RHS .EQ. 2) GO TO 44
      MN = M*N
      L2 = L
      IF (LHS .EQ. 2) L2 = L + MN
      LW = L2 + MN
      ERR = LW + LRAT - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      IF (LHS .EQ. 2) TOP = TOP + 1
      LSTK(TOP) = L2
      MSTK(TOP) = M
      NSTK(TOP) = N
      CALL RSET(LHS*MN,0.0D0,STKI(L),1)
      DO 42 I = 1, MN
         CALL RAT(STKR(L),LRAT,MRAT,S,T,STKR(LW))
         STKR(L) = S
         STKR(L2) = T
         IF (LHS .EQ. 1) STKR(L) = FLOP(S/T)
         L = L + 1
         L2 = L2 + 1
   42 CONTINUE
      GO TO 99
   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
C
80     CONTINUE
       IF (RHS .EQ. 1)THEN
        IPLTYP=0
       ELSE
        IPLTYP=1
        TOP = TOP-1
       ENDIF
       CALL PLOT(TOP,MSTK(TOP),NSTK(TOP),IPLTYP)
       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 *******************START OF AMIGA SPECIFIC PLOT STUFF*********************
C
      INTEGER COLOR1,COLOR2,COLOR3,COLOR4
C
C MAKE SURE THAT THE NECESSARY AMIGA PLOT STUFF HANGS AROUND THROUGHOUT THE
C PROGRAM
C
      INCLUDE INTUIT.INC
      INTEGER*4 COL1,COL2,COL3,BGRP
      LOGICAL PLTST,SETBG,BNHERE
      INTEGER*4 WIDTH,HEIGHT,ICOLOR,Window,Screen,viewport,scrht,scrwth
      INTEGER*4 Xrosiz,Yrosiz,GFXBASE
      CHARACTER*16 w_title
      REAL*4 DEVID, XLENCM, YLENCM, XRES, YRES,
     1  NDCLRS, IDVBTS, NFLINE, XCLIPD, YCLIPD
      COMMON /MATPLT/ COL1,COL2,COL3,BGRP,PLTST,SETBG,BNHERE
	COMMON /WNDO/ WIDTH,HEIGHT,ICOLOR,Screen, Window,viewport
     1   ,scrht,scrwth,Xrosiz,Yrosiz,w_title,NewWindow,NewScreen
     2   ,GFXBASE
	COMMON /PLTPRM/ CXSIZE, CYSIZE, TICKLN, YVINI
	COMMON /GCCLIP/ XCM0, XCM1, YCM0, YCM1
	COMMON /GCCOFF/ XOFF, YOFF
	COMMON /GCCPAR/ CSIZE, CCOS, CSIN
	COMMON /GCCPOS/ XAPOS, YAPOS, IVIS, LCURNT
	COMMON /PLTCOM/ UX0, UDX, UY0, UDY, LOGX, LOGY
	COMMON /PLTSIZ/ XVSTRT, YVSTRT, XVLEN, YVLEN
	COMMON /PLTCLP/ XMIN,XMAX,YMIN,YMAX
	COMMON /GCDCHR/ DEVID, XLENCM, YLENCM, XRES, YRES,
     1  NDCLRS, IDVBTS, NFLINE, XCLIPD, YCLIPD
	COMMON /GCDPRM/ XS, YS, XT, YT, RCOS, RSIN
	COMMON /GCDSEL/ IDEV
	COMMON /GCLTYP/ ILNTYP, DLEFT, DIST(4,3), LINILT, LPOSND
	COMMON /GCVPOS/ XVPOS, YVPOS
	LOGICAL*1 LINILT, LPOSND
	LOGICAL LCURNT
	LOGICAL*1 LOGX, LOGY
C
      INTEGER PLTCNT,PLTMAX
      CHARACTER*1 ISAV(10,720)
C
C THE PLTSAV COMMON
C
      COMMON /SAV/ PLTCNT,IPLTYP(10),PLTMAX,ISAV
C
C ********************** END OF AMIGA SPECIFIC PLOT STUFF*******************
C
C THE MATLAB CHARACTERS
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
C AMIGA CURSOR COLOR STUFF
C
      DATA COLOR1/Z'9B313B33'/,COLOR2/Z'333B3431'/,COLOR3/Z'3B376D00'/
      DATA COLOR4/Z'9B30306D'/
C
C START BY SETTING THE AMIGA PLOT START STATUS TO FALSE
C
      PLTST = .FALSE.
      BNHERE = .FALSE.
      PLTMAX = 0
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)COLOR1,COLOR2,COLOR3,COLOR4,
     1COLOR1,COLOR2,COLOR3,COLOR4
  100 FORMAT(//7X,2A4,A3,'< AMIGA MATLAB >',A4
     $  /6X,2A4,A3,'Version of 6/20/89',A4)
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 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
      INTEGER COLOR1,COLOR2
      COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
      DATA COLOR1/Z'9B33336D'/,COLOR2/Z'9B30306D'/
      WRITE(WTE,10)COLOR1,COLOR2
      IF (WIO .NE. 0) WRITE(WIO,10)COLOR1,COLOR2
   10 FORMAT(/1X,A4,'<>',A4,$)
      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
      IF (OP .GT. DOT) GO TO 70
C
C     ADDITION
   01 IF (M .LT. 0) GO TO 50
      IF (M2 .LT. 0) GO TO 52
      IF (M .NE. M2) CALL ERROR(8)
      IF (ERR .GT. 0) RETURN
      IF (N .NE. N2) CALL ERROR(8)
      IF (ERR .GT. 0) RETURN
      CALL WAXPY(M*N,1.0D0,0.0D0,STKR(L2),STKI(L2),1,
     $            STKR(L),STKI(L),1)
      GO TO 99
C
C     SUBTRACTION
   03 IF (M .LT. 0) GO TO 54
      IF (M2 .LT. 0) GO TO 56
      IF (M .NE. M2) CALL ERROR(9)
      IF (ERR .GT. 0) RETURN
      IF (N .NE. N2) CALL ERROR(9)
      IF (ERR .GT. 0) RETURN
      CALL WAXPY(M*N,-1.0D0,0.0D0,STKR(L2),STKI(L2),1,
     $            STKR(L),STKI(L),1)
      GO TO 99
C
C     MULTIPLICATION
   05 IF (M2*M2*N2 .EQ. 1) GO TO 10
      IF (M*N .EQ. 1) GO TO 11
      IF (M2*N2 .EQ. 1) GO TO 10
      IF (N .NE. M2) CALL ERROR(10)
      IF (ERR .GT. 0) RETURN
      MN = M*N2
      LL = L + MN
      ERR = LL+M*N+M2*N2 - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      CALL WCOPY(M*N+M2*N2,STKR(L),STKI(L),-1,STKR(LL),STKI(LL),-1)
      DO 08 J = 1, N2
      DO 08 I = 1, M
        K1 = L + MN + (I-1)
        K2 = L2 + MN + (J-1)*M2
        K = L + (I-1) + (J-1)*M
        STKR(K) = WDOTUR(N,STKR(K1),STKI(K1),M,STKR(K2),STKI(K2),1)
        STKI(K) = WDOTUI(N,STKR(K1),STKI(K1),M,STKR(K2),STKI(K2),1)
   08 CONTINUE
      NSTK(TOP) = N2
      GO TO 99
C
C     MULTIPLICATION BY SCALAR
   10 SR = STKR(L2)
      SI = STKI(L2)
      L1 = L
      GO TO 13
   11 SR = STKR(L)
      SI = STKI(L)
      L1 = L+1
      MSTK(TOP) = M2
      NSTK(TOP) = N2
   13 MN = MSTK(TOP)*NSTK(TOP)
      CALL WSCAL(MN,SR,SI,STKR(L1),STKI(L1),1)
      IF (L1.NE.L)
     $   CALL WCOPY(MN,STKR(L1),STKI(L1),1,STKR(L),STKI(L),1)
      GO TO 99
C
C     RIGHT DIVISION
   20 IF (M2*N2 .EQ. 1) GO TO 21
      IF (M2 .EQ. N2) FUN = 1
      IF (M2 .NE. N2) FUN = 4
      FIN = -1
      RHS = 2
      GO TO 99
   21 SR = STKR(L2)
      SI = STKI(L2)
      MN = M*N
      DO 22 I = 1, MN
         LL = L+I-1
         CALL WDIV(STKR(LL),STKI(LL),SR,SI,STKR(LL),STKI(LL))
         IF (ERR .GT. 0) RETURN
   22 CONTINUE
      GO TO 99
C
C     LEFT DIVISION
   25 IF (M*N .EQ. 1) GO TO 26
      IF (M .EQ. N) FUN = 1
      IF (M .NE. N) FUN = 4
      FIN = -2
      RHS = 2
      GO TO 99
   26 SR = STKR(L)
      SI = STKI(L)
      MSTK(TOP) = M2
      NSTK(TOP) = N2
      MN = M2*N2
      DO 27 I = 1, MN
         LL = L+I-1
         CALL WDIV(STKR(LL+1),STKI(LL+1),SR,SI,STKR(LL),STKI(LL))
         IF (ERR .GT. 0) RETURN
   27 CONTINUE
      GO TO 99
C
C     POWER
   30 IF (M2*N2 .NE. 1) CALL ERROR(30)
      IF (ERR .GT. 0) RETURN
      IF (M .NE. N) CALL ERROR(20)
      IF (ERR .GT. 0) RETURN
      NEXP = IDINT(STKR(L2))
      IF (STKR(L2) .NE. DFLOAT(NEXP)) GO TO 39
      IF (STKI(L2) .NE. 0.0D0) GO TO 39
      IF (NEXP .LT. 2) GO TO 39
      MN = M*N
      ERR = L2+MN+N - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      CALL WCOPY(MN,STKR(L),STKI(L),1,STKR(L2),STKI(L2),1)
      L3 = L2+MN
      DO 36 KEXP = 2, NEXP
        DO 35 J = 1, N
          LS = L+(J-1)*N
          CALL WCOPY(N,STKR(LS),STKI(LS),1,STKR(L3),STKI(L3),1)
          DO 34 I = 1, N
            LS = L2+I-1
            LL = L+I-1+(J-1)*N
            STKR(LL) = WDOTUR(N,STKR(LS),STKI(LS),N,STKR(L3),STKI(L3),1)
            STKI(LL) = WDOTUI(N,STKR(LS),STKI(LS),N,STKR(L3),STKI(L3),1)
   34     CONTINUE
   35   CONTINUE
   36 CONTINUE
      GO TO 99
C
C     NONINTEGER OR NONPOSITIVE POWER, USE EIGENVECTORS
   39 FUN = 2
      FIN = 0
      GO TO 99
C
C     ADD OR SUBTRACT SCALAR
   50 IF (M2 .NE. N2) CALL ERROR(8)
      IF (ERR .GT. 0) RETURN
      M = M2
      N = N2
      MSTK(TOP) = M
      NSTK(TOP) = N
      SR = STKR(L)
      SI = STKI(L)
      CALL WCOPY(M*N,STKR(L+1),STKI(L+1),1,STKR(L),STKI(L),1)
      GO TO 58
   52 IF (M .NE. N) CALL ERROR(8)
      IF (ERR .GT. 0) RETURN
      SR = STKR(L2)
      SI = STKI(L2)
      GO TO 58
   54 IF (M2 .NE. N2) CALL ERROR(9)
      IF (ERR .GT. 0) RETURN
      M = M2
      N = N2
      MSTK(TOP) = M
      NSTK(TOP) = N
      SR = STKR(L)
      SI = STKI(L)
      CALL WCOPY(M*N,STKR(L+1),STKI(L+1),1,STKR(L),STKI(L),1)
      CALL WRSCAL(M*N,-1.0D0,STKR(L),STKI(L),1)
      GO TO 58
   56 IF (M .NE. N) CALL ERROR(9)
      IF (ERR .GT. 0) RETURN
      SR = -STKR(L2)
      SI = -STKI(L2)
      GO TO 58
   58 DO 59 I = 1, N
         LL = L + (I-1)*(N+1)
         STKR(LL) = FLOP(STKR(LL)+SR)
         STKI(LL) = FLOP(STKI(LL)+SI)
   59 CONTINUE
      GO TO 99
C
C     COLON
   60 E2 = STKR(L2)
      ST = 1.0D0
      N = 0
      IF (RHS .LT. 3) GO TO 61
      ST = STKR(L)
      TOP = TOP-1
      L = LSTK(TOP)
      IF (ST .EQ. 0.0D0) GO TO 63
   61 E1 = STKR(L)
C     CHECK FOR CLAUSE
      IF (RSTK(PT) .EQ. 3) GO TO 64
      ERR = L + MAX0(3,IDINT((E2-E1)/ST)) - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
   62 IF (ST .GT. 0.0D0 .AND. STKR(L) .GT. E2) GO TO 63
      IF (ST .LT. 0.0D0 .AND. STKR(L) .LT. E2) GO TO 63
        N = N+1
        L = L+1
        STKR(L) = E1 + DFLOAT(N)*ST
        STKI(L) = 0.0D0
        GO TO 62
   63 NSTK(TOP) = N
      MSTK(TOP) = 1
      IF (N .EQ. 0) MSTK(TOP) = 0
      GO TO 99
C
C     FOR CLAUSE
   64 STKR(L) = E1
      STKR(L+1) = ST
      STKR(L+2) = E2
      MSTK(TOP) = -3
      NSTK(TOP) = -1
      GO TO 99
C
C     ELEMENTWISE OPERATIONS
   70 OP = OP - DOT
      IF (M.NE.M2 .OR. N.NE.N2) CALL ERROR(10)
      IF (ERR .GT. 0) RETURN
      MN = M*N
      DO 72 I = 1, MN
         J = L+I-1
         K = L2+I-1
         IF (OP .EQ. STAR)
     $      CALL WMUL(STKR(J),STKI(J),STKR(K),STKI(K),STKR(J),STKI(J))
         IF (OP .EQ. SLASH)
     $      CALL WDIV(STKR(J),STKI(J),STKR(K),STKI(K),STKR(J),STKI(J))
         IF (OP .EQ. BSLASH)
     $      CALL WDIV(STKR(K),STKI(K),STKR(J),STKI(J),STKR(J),STKI(J))
         IF (ERR .GT. 0) RETURN
   72 CONTINUE
      GO TO 99
C
C     KRONECKER
   80 FIN = OP - 2*DOT - STAR + 11
      FUN = 6
      TOP = TOP + 1
      RHS = 2
      GO TO 99
C
   99 RETURN
      END

      SUBROUTINE STACKG(ID)
      INTEGER ID(4)
C
C     GET VARIABLES FROM STORAGE
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
      IF (DDT .EQ. 1) WRITE(WTE,100) ID
  100 FORMAT(1X,'STACKG',4I4)
      CALL PUTID(IDSTK(1,BOT-1), ID)
      K = LSIZE+1
   10 K = K-1
      IF (.NOT.EQID(IDSTK(1,K), ID)) GO TO 10
      IF (K .GE. LSIZE-1 .AND. RHS .GT. 0) GO TO 98
      IF (K .EQ. BOT-1) GO TO 98
      LK = LSTK(K)
      IF (RHS .EQ. 1) GO TO 40
      IF (RHS .EQ. 2) GO TO 60
      IF (RHS .GT. 2) CALL ERROR(21)
      IF (ERR .GT. 0) RETURN
      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
C
C     LOAD VARIABLE TO TOP OF STACK
      LSTK(TOP) = L
      MSTK(TOP) = MSTK(K)
      NSTK(TOP) = NSTK(K)
      MN = MSTK(K)*NSTK(K)
      ERR = L+MN - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
C     IF RAND, MATFN6 GENERATES RANDOM NUMBER
      IF (K .EQ. LSIZE) GO TO 97
      CALL WCOPY(MN,STKR(LK),STKI(LK),1,STKR(L),STKI(L),1)
      GO TO 99
C
C     VECT(ARG)
   40 IF (MSTK(TOP) .EQ. 0) GO TO 99
      L = LSTK(TOP)
      MN = MSTK(TOP)*NSTK(TOP)
      MNK = MSTK(K)*NSTK(K)
      IF (MSTK(TOP) .LT. 0) MN = MNK
      DO 50 I = 1, MN
        LL = L+I-1
        LS = LK+I-1
        IF (MSTK(TOP) .GT. 0) LS = LK + IDINT(STKR(LL)) - 1
        IF (LS .LT. LK .OR. LS .GE. LK+MNK) CALL ERROR(21)
        IF (ERR .GT. 0) RETURN
        STKR(LL) = STKR(LS)
        STKI(LL) = STKI(LS)
   50 CONTINUE
      MSTK(TOP) = 1
      NSTK(TOP) = 1
      IF (MSTK(K) .GT. 1) MSTK(TOP) = MN
      IF (MSTK(K) .EQ. 1) NSTK(TOP) = MN
      GO TO 99
C
C     MATRIX(ARG,ARG)
   60 TOP = TOP-1
      L = LSTK(TOP)
      IF (MSTK(TOP+1) .EQ. 0) MSTK(TOP) = 0
      IF (MSTK(TOP) .EQ. 0) GO TO 99
      L2 = LSTK(TOP+1)
      M = MSTK(TOP)*NSTK(TOP)
      IF (MSTK(TOP) .LT. 0) M = MSTK(K)
      N = MSTK(TOP+1)*NSTK(TOP+1)
      IF (MSTK(TOP+1) .LT. 0) N = NSTK(K)
      L3 = L2 + N
      MK = MSTK(K)
      MNK = MSTK(K)*NSTK(K)
      DO 70 J = 1, N
      DO 70 I = 1, M
        LI = L+I-1
        IF (MSTK(TOP) .GT. 0) LI = L + IDINT(STKR(LI)) - 1
        LJ = L2+J-1
        IF (MSTK(TOP+1) .GT. 0) LJ = L2 + IDINT(STKR(LJ)) - 1
        LS = LK + LI-L + (LJ-L2)*MK
        IF (LS.LT.LK .OR. LS.GE.LK+MNK) CALL ERROR(21)
        IF (ERR .GT. 0) RETURN
        LL = L3 + I-1 + (J-1)*M
        STKR(LL) = STKR(LS)
        STKI(LL) = STKI(LS)
   70 CONTINUE
      MN = M*N
      CALL WCOPY(MN,STKR(L3),STKI(L3),1,STKR(L),STKI(L),1)
      MSTK(TOP) = M
      NSTK(TOP) = N
      GO TO 99
   97 FIN = 7
      FUN = 6
      RETURN
   98 FIN = 0
      RETURN
   99 FIN = -1
      FUN = 0
      RETURN
      END

      SUBROUTINE STACKP(ID)
      INTEGER ID(4)
C
C     PUT VARIABLES INTO STORAGE
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 SEMI
      DATA SEMI/39/
      IF (DDT .EQ. 1) WRITE(WTE,100) ID
  100 FORMAT(1X,'STACKP',4I4)
      IF (TOP .LE. 0) CALL ERROR(1)
      IF (ERR .GT. 0) RETURN
      CALL FUNS(ID)
      IF (FIN .NE. 0) CALL ERROR(25)
      IF (ERR .GT. 0) RETURN
      M = MSTK(TOP)
      N = NSTK(TOP)
      IF (M .GT. 0) L = LSTK(TOP)
      IF (M .LT. 0) CALL ERROR(14)
      IF (ERR .GT. 0) RETURN
      IF (M .EQ. 0 .AND. N .NE. 0) GO TO 99
      MN = M*N
      LK = 0
      MK = 1
      NK = 0
      LT = 0
      MT = 0
      NT = 0
C
C     DOES VARIABLE ALREADY EXIST
      CALL PUTID(IDSTK(1,BOT-1),ID)
      K = LSIZE+1
   05 K = K-1
      IF (.NOT.EQID(IDSTK(1,K),ID)) GO TO 05
      IF (K .EQ. BOT-1) GO TO 30
      LK = LSTK(K)
      MK = MSTK(K)
      NK = NSTK(K)
      MNK = MK*NK
      IF (RHS .EQ. 0) GO TO 20
      IF (RHS .GT. 2) CALL ERROR(15)
      IF (ERR .GT. 0) RETURN
      MT = MK
      NT = NK
      LT = L + MN
      ERR = LT + MNK - LSTK(BOT)
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      CALL WCOPY(MNK,STKR(LK),STKI(LK),1,STKR(LT),STKI(LT),1)
C
C     DOES IT FIT
   20 IF (RHS.EQ.0 .AND. MN.EQ.MNK) GO TO 40
      IF (K .GE. LSIZE-3) CALL ERROR(13)
      IF (ERR .GT. 0) RETURN
C
C     SHIFT STORAGE
      IF (K .EQ. BOT) GO TO 25
      LS = LSTK(BOT)
      LL = LS + MNK
      CALL WCOPY(LK-LS,STKR(LS),STKI(LS),-1,STKR(LL),STKI(LL),-1)
      KM1 = K-1
      DO 24 IB = BOT, KM1
        I = BOT+KM1-IB
        CALL PUTID(IDSTK(1,I+1),IDSTK(1,I))
        MSTK(I+1) = MSTK(I)
        NSTK(I+1) = NSTK(I)
        LSTK(I+1) = LSTK(I)+MNK
   24 CONTINUE
C
C     DESTROY OLD VARIABLE
   25 BOT = BOT+1
C
C     CREATE NEW VARIABLE
   30 IF (MN .EQ. 0) GO TO 99
      IF (BOT-2 .LE. TOP) CALL ERROR(18)
      IF (ERR .GT. 0) RETURN
      K = BOT-1
      CALL PUTID(IDSTK(1,K), ID)
      IF (RHS .EQ. 1) GO TO 50
      IF (RHS .EQ. 2) GO TO 55
C
C     STORE
   40 IF (K .LT. LSIZE) LSTK(K) = LSTK(K+1) - MN
      MSTK(K) = M
      NSTK(K) = N
      LK = LSTK(K)
      CALL WCOPY(MN,STKR(L),STKI(L),-1,STKR(LK),STKI(LK),-1)
      GO TO 90
C
C     VECT(ARG)
   50 IF (MSTK(TOP-1) .LT. 0) GO TO 59
      MN1 = 1
      MN2 = 1
      L1 = 0
      L2 = 0
      IF (N.NE.1 .OR. NK.NE.1) GO TO 52
      L1 = LSTK(TOP-1)
      M1 = MSTK(TOP-1)
      MN1 = M1*NSTK(TOP-1)
      M2 = -1
      GO TO 60
   52 IF (M.NE.1 .OR. MK.NE.1) CALL ERROR(15)
      IF (ERR .GT. 0) RETURN
      L2 = LSTK(TOP-1)
      M2 = MSTK(TOP-1)
      MN2 = M2*NSTK(TOP-1)
      M1 = -1
      GO TO 60
C
C     MATRIX(ARG,ARG)
   55 IF (MSTK(TOP-1).LT.0 .AND. MSTK(TOP-2).LT.0) GO TO 59
      L2 = LSTK(TOP-1)
      M2 = MSTK(TOP-1)
      MN2 = M2*NSTK(TOP-1)
      IF (M2 .LT. 0) MN2 = N
      L1 = LSTK(TOP-2)
      M1 = MSTK(TOP-2)
      MN1 = M1*NSTK(TOP-2)
      IF (M1 .LT. 0) MN1 = M
      GO TO 60
C
   59 IF (MN .NE. MNK) CALL ERROR(15)
      IF (ERR .GT. 0) RETURN
      LK = LSTK(K)
      CALL WCOPY(MN,STKR(L),STKI(L),-1,STKR(LK),STKI(LK),-1)
      GO TO 90
C
   60 IF (MN1.NE.M .OR. MN2.NE.N) CALL ERROR(15)
      IF (ERR .GT. 0) RETURN
      LL = 1
      IF (M1 .LT. 0) GO TO 62
      DO 61 I = 1, MN1
         LS = L1+I-1
         MK = MAX0(MK,IDINT(STKR(LS)))
         LL = MIN0(LL,IDINT(STKR(LS)))
   61 CONTINUE
   62 MK = MAX0(MK,M)
      IF (M2 .LT. 0) GO TO 64
      DO 63 I = 1, MN2
         LS = L2+I-1
         NK = MAX0(NK,IDINT(STKR(LS)))
         LL = MIN0(LL,IDINT(STKR(LS)))
   63 CONTINUE
   64 NK = MAX0(NK,N)
      IF (LL .LT. 1) CALL ERROR(21)
      IF (ERR .GT. 0) RETURN
      MNK = MK*NK
      LK = LSTK(K+1) - MNK
      ERR = LT + MT*NT - LK
      IF (ERR .GT. 0) CALL ERROR(17)
      IF (ERR .GT. 0) RETURN
      LSTK(K) = LK
      MSTK(K) = MK
      NSTK(K) = NK
      CALL WSET(MNK,0.0D0,0.0D0,STKR(LK),STKI(LK),1)
      IF (NT .LT. 1) GO TO 67
      DO 66 J = 1, NT
         LS = LT+(J-1)*MT
         LL = LK+(J-1)*MK
         CALL WCOPY(MT,STKR(LS),STKI(LS),-1,STKR(LL),STKI(LL),-1)
   66 CONTINUE
   67 DO 68 J = 1, N
      DO 68 I = 1, M
        LI = L1+I-1
        IF (M1 .GT. 0) LI = L1 + IDINT(STKR(LI)) - 1
        LJ = L2+J-1
        IF (M2 .GT. 0) LJ = L2 + IDINT(STKR(LJ)) - 1
        LL = LK+LI-L1+(LJ-L2)*MK
        LS = L+I-1+(J-1)*M
        STKR(LL) = STKR(LS)
        STKI(LL) = STKI(LS)
   68 CONTINUE
      GO TO 90
C
C     PRINT IF DESIRED AND POP STACK
   90 IF (SYM.NE.SEMI .AND. LCT(3).EQ.0) CALL PRINT(ID,K)
      IF (SYM.EQ.SEMI .AND. LCT(3).EQ.1) CALL PRINT(ID,K)
      IF (K .EQ. BOT-1) BOT = BOT-1
   99 IF (M .NE. 0) TOP = TOP - 1 - RHS
      IF (M .EQ. 0) TOP = TOP - 1
      RETURN
      END

      SUBROUTINE TERM
      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 R,OP,BSLASH,STAR,SLASH,DOT
      DATA BSLASH/45/,STAR/43/,SLASH/44/,DOT/47/
      IF (DDT .EQ. 1) WRITE(WTE,100) PT,RSTK(PT)
  100 FORMAT(1X,'TERM  ',2I4)
      R = RSTK(PT)
      GO TO (99,99,99,99,99,01,01,05,25,99,99,99,99,99,35,99,99,99,99),R
   01 PT = PT+1
      RSTK(PT) = 8
C     *CALL* FACTOR
      RETURN
   05 PT = PT-1
   10 OP = 0
      IF (SYM .EQ. DOT) OP = DOT
      IF (SYM .EQ. DOT) CALL GETSYM
      IF (SYM.EQ.STAR .OR. SYM.EQ.SLASH .OR. SYM.EQ.BSLASH) GO TO 20
      RETURN
   20 OP = OP + SYM
      CALL GETSYM
      IF (SYM .EQ. DOT) OP = OP + SYM
      IF (SYM .EQ. DOT) CALL GETSYM
      PT = PT+1
      PSTK(PT) = OP
      RSTK(PT) = 9
C     *CALL* FACTOR
      RETURN
   25 OP = PSTK(PT)
      PT = PT-1
      CALL STACK2(OP)
      IF (ERR .GT. 0) RETURN
C     SOME BINARY OPS DONE IN MATFNS
      IF (FUN .EQ. 0) GO TO 10
      PT = PT+1
      RSTK(PT) = 15
C     *CALL* MATFN
      RETURN
   35 PT = PT-1
      GO TO 10
   99 CALL ERROR(22)
      IF (ERR .GT. 0) RETURN
      RETURN
      END

      SUBROUTINE USER(A,M,N,S,T)
      DOUBLE PRECISION A(M,N),S,T
C
      INTEGER A3(9)
      DATA A3 /-149,537,-27,-50,180,-9,-154,546,-25/
      IF (A(1,1) .NE. 3.0D0) RETURN
      DO 10 I = 1, 9
         A(I,1) = DFLOAT(A3(I))
   10 CONTINUE
      M = 3
      N = 3
      RETURN
      END

      SUBROUTINE XCHAR(BUF,K)
      INTEGER BUF(1),K
C
C     SYSTEM DEPENDENT ROUTINE TO HANDLE SPECIAL CHARACTERS
C
C
      INTEGER BACK,MASK
      DATA BACK/Z'20202008'/,MASK/Z'000000FF'/
C
      IF (BUF(1) .EQ. BACK) K = -1
      L = BUF(1) .AND. MASK
      IF (K .NE. -1) WRITE(6,10) BUF(1),L
   10 FORMAT(1X,1H',A1,4H' = ,Z2,' hex is not a MATLAB character.')
      RETURN
      END
      SUBROUTINE WGECO(AR,AI,LDA,N,IPVT,RCOND,ZR,ZI)
      INTEGER LDA,N,IPVT(1)
      DOUBLE PRECISION AR(LDA,1),AI(LDA,1),ZR(1),ZI(1)
      DOUBLE PRECISION RCOND
C
C     WGECO FACTORS A DOUBLE-COMPLEX MATRIX BY GAUSSIAN ELIMINATION
C     AND ESTIMATES THE CONDITION OF THE MATRIX.
C
C     IF  RCOND  IS NOT NEEDED, WGEFA IS SLIGHTLY FASTER.
C     TO SOLVE  A*X = B , FOLLOW WGECO BY WGESL.
C     TO COMPUTE  INVERSE(A)*C , FOLLOW WGECO BY WGESL.
C     TO COMPUTE  DETERMINANT(A) , FOLLOW WGECO BY WGEDI.
C     TO COMPUTE  INVERSE(A) , FOLLOW WGECO BY WGEDI.
C
C     ON ENTRY
C
C        A       DOUBLE-COMPLEX(LDA, N)
C                THE MATRIX TO BE FACTORED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        RCOND   DOUBLE PRECISION
C                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  A .
C                FOR THE SYSTEM  A*X = B , RELATIVE PERTURBATIONS
C                IN  A  AND  B  OF SIZE  EPSILON  MAY CAUSE
C                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND .
C                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION
C        1.0 + RCOND .EQ. 1.0
C                IS TRUE, THEN  A  MAY BE SINGULAR TO WORKING
C                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF
C                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
C                UNDERFLOWS.
C
C        Z       DOUBLE-COMPLEX(N)
C                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
C                IF  A  IS CLOSE TO A SINGULAR MATRIX, THEN  Z  IS
C                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C     LINPACK. THIS VERSION DATED 07/01/79 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     LINPACK WGEFA
C     BLAS WAXPY,WDOTC,WASUM
C     FORTRAN DABS,DMAX1
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION WDOTCR,WDOTCI,EKR,EKI,TR,TI,WKR,WKI,WKMR,WKMI
      DOUBLE PRECISION ANORM,S,WASUM,SM,YNORM,FLOP
      INTEGER INFO,J,K,KB,KP1,L
C
      DOUBLE PRECISION ZDUMR,ZDUMI
      DOUBLE PRECISION CABS1
      CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
C
C     COMPUTE 1-NORM OF A
C
      ANORM = 0.0D0
      DO 10 J = 1, N
         ANORM = DMAX1(ANORM,WASUM(N,AR(1,J),AI(1,J),1))
   10 CONTINUE
C
C     FACTOR
C
      CALL WGEFA(AR,AI,LDA,N,IPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  CTRANS(A)*Y = E .
C     CTRANS(A)  IS THE CONJUGATE TRANSPOSE OF A .
C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C     GROWTH IN THE ELEMENTS OF W  WHERE  CTRANS(U)*W = E .
C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C     SOLVE CTRANS(U)*W = E
C
      EKR = 1.0D0
      EKI = 0.0D0
      DO 20 J = 1, N
         ZR(J) = 0.0D0
         ZI(J) = 0.0D0
   20 CONTINUE
      DO 110 K = 1, N
         CALL WSIGN(EKR,EKI,-ZR(K),-ZI(K),EKR,EKI)
         IF (CABS1(EKR-ZR(K),EKI-ZI(K))
     *       .LE. CABS1(AR(K,K),AI(K,K))) GO TO 40
            S = CABS1(AR(K,K),AI(K,K))
     *          /CABS1(EKR-ZR(K),EKI-ZI(K))
            CALL WRSCAL(N,S,ZR,ZI,1)
            EKR = S*EKR
            EKI = S*EKI
   40    CONTINUE
         WKR = EKR - ZR(K)
         WKI = EKI - ZI(K)
         WKMR = -EKR - ZR(K)
         WKMI = -EKI - ZI(K)
         S = CABS1(WKR,WKI)
         SM = CABS1(WKMR,WKMI)
         IF (CABS1(AR(K,K),AI(K,K)) .EQ. 0.0D0) GO TO 50
            CALL WDIV(WKR,WKI,AR(K,K),-AI(K,K),WKR,WKI)
            CALL WDIV(WKMR,WKMI,AR(K,K),-AI(K,K),WKMR,WKMI)
         GO TO 60
   50    CONTINUE
            WKR = 1.0D0
            WKI = 0.0D0
            WKMR = 1.0D0
            WKMI = 0.0D0
   60    CONTINUE
         KP1 = K + 1
         IF (KP1 .GT. N) GO TO 100
            DO 70 J = KP1, N
               CALL WMUL(WKMR,WKMI,AR(K,J),-AI(K,J),TR,TI)
               SM = FLOP(SM + CABS1(ZR(J)+TR,ZI(J)+TI))
               CALL WAXPY(1,WKR,WKI,AR(K,J),-AI(K,J),1,
     $ ZR(J),ZI(J),1)
               S = FLOP(S + CABS1(ZR(J),ZI(J)))
   70       CONTINUE
            IF (S .GE. SM) GO TO 90
               TR = WKMR - WKR
               TI = WKMI - WKI
               WKR = WKMR
               WKI = WKMI
               DO 80 J = KP1, N
                  CALL WAXPY(1,TR,TI,AR(K,J),-AI(K,J),1,
     $    ZR(J),ZI(J),1)
   80          CONTINUE
   90       CONTINUE
  100    CONTINUE
         ZR(K) = WKR
         ZI(K) = WKI
  110 CONTINUE
      S = 1.0D0/WASUM(N,ZR,ZI,1)
      CALL WRSCAL(N,S,ZR,ZI,1)
C
C     SOLVE CTRANS(L)*Y = W
C
      DO 140 KB = 1, N
         K = N + 1 - KB
         IF (K .GE. N) GO TO 120
            ZR(K) = ZR(K)
     *            + WDOTCR(N-K,AR(K+1,K),AI(K+1,K),1,ZR(K+1),ZI(K+1),1)
            ZI(K) = ZI(K)
     *            + WDOTCI(N-K,AR(K+1,K),AI(K+1,K),1,ZR(K+1),ZI(K+1),1)
  120    CONTINUE
         IF (CABS1(ZR(K),ZI(K)) .LE. 1.0D0) GO TO 130
            S = 1.0D0/CABS1(ZR(K),ZI(K))
            CALL WRSCAL(N,S,ZR,ZI,1)
  130    CONTINUE
         L = IPVT(K)
         TR = ZR(L)
         TI = ZI(L)
         ZR(L) = ZR(K)
         ZI(L) = ZI(K)
         ZR(K) = TR
         ZI(K) = TI
  140 CONTINUE
      S = 1.0D0/WASUM(N,ZR,ZI,1)
      CALL WRSCAL(N,S,ZR,ZI,1)
C
      YNORM = 1.0D0
C
C     SOLVE L*V = Y
C
      DO 160 K = 1, N
         L = IPVT(K)
         TR = ZR(L)
         TI = ZI(L)
         ZR(L) = ZR(K)
         ZI(L) = ZI(K)
         ZR(K) = TR
         ZI(K) = TI
         IF (K .LT. N)
     *      CALL WAXPY(N-K,TR,TI,AR(K+1,K),AI(K+1,K),1,ZR(K+1),ZI(K+1),
     *                 1)
         IF (CABS1(ZR(K),ZI(K)) .LE. 1.0D0) GO TO 150
            S = 1.0D0/CABS1(ZR(K),ZI(K))
            CALL WRSCAL(N,S,ZR,ZI,1)
            YNORM = S*YNORM
  150    CONTINUE
  160 CONTINUE
      S = 1.0D0/WASUM(N,ZR,ZI,1)
      CALL WRSCAL(N,S,ZR,ZI,1)
      YNORM = S*YNORM
C
C     SOLVE  U*Z = V
C
      DO 200 KB = 1, N
         K = N + 1 - KB
         IF (CABS1(ZR(K),ZI(K))
     *       .LE. CABS1(AR(K,K),AI(K,K))) GO TO 170
            S = CABS1(AR(K,K),AI(K,K))
     *          /CABS1(ZR(K),ZI(K))
            CALL WRSCAL(N,S,ZR,ZI,1)
            YNORM = S*YNORM
  170    CONTINUE
         IF (CABS1(AR(K,K),AI(K,K)) .EQ. 0.0D0) GO TO 180
            CALL WDIV(ZR(K),ZI(K),AR(K,K),AI(K,K),ZR(K),ZI(K))
  180    CONTINUE
         IF (CABS1(AR(K,K),AI(K,K)) .NE. 0.0D0) GO TO 190
            ZR(K) = 1.0D0
            ZI(K) = 0.0D0
  190    CONTINUE
         TR = -ZR(K)
         TI = -ZI(K)
         CALL WAXPY(K-1,TR,TI,AR(1,K),AI(1,K),1,ZR(1),ZI(1),1)
  200 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0D0/WASUM(N,ZR,ZI,1)
      CALL WRSCAL(N,S,ZR,ZI,1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0
      RETURN
      END
      SUBROUTINE WGEFA(AR,AI,LDA,N,IPVT,INFO)
      INTEGER LDA,N,IPVT(1),INFO
      DOUBLE PRECISION AR(LDA,1),AI(LDA,1)
C
C     WGEFA FACTORS A DOUBLE-COMPLEX MATRIX BY GAUSSIAN ELIMINATION.
C
C     WGEFA IS USUALLY CALLED BY WGECO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C     (TIME FOR WGECO) = (1 + 9/N)*(TIME FOR WGEFA) .
C
C     ON ENTRY
C
C        A       DOUBLE-COMPLEX(LDA, N)
C                THE MATRIX TO BE FACTORED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
C  CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C  INDICATE THAT WGESL OR WGEDI WILL DIVIDE BY ZERO
C  IF CALLED.  USE  RCOND  IN WGECO FOR A RELIABLE
C  INDICATION OF SINGULARITY.
C
C     LINPACK. THIS VERSION DATED 07/01/79 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS WAXPY,WSCAL,IWAMAX
C     FORTRAN DABS
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION TR,TI
      INTEGER IWAMAX,J,K,KP1,L,NM1
C
      DOUBLE PRECISION ZDUMR,ZDUMI
      DOUBLE PRECISION CABS1
      CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      INFO = 0
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
C
C        FIND L = PIVOT INDEX
C
         L = IWAMAX(N-K+1,AR(K,K),AI(K,K),1) + K - 1
         IPVT(K) = L
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (CABS1(AR(L,K),AI(L,K)) .EQ. 0.0D0) GO TO 40
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. K) GO TO 10
               TR = AR(L,K)
               TI = AI(L,K)
               AR(L,K) = AR(K,K)
               AI(L,K) = AI(K,K)
               AR(K,K) = TR
               AI(K,K) = TI
   10       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            CALL WDIV(-1.0D0,0.0D0,AR(K,K),AI(K,K),TR,TI)
            CALL WSCAL(N-K,TR,TI,AR(K+1,K),AI(K+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            DO 30 J = KP1, N
               TR = AR(L,J)
               TI = AI(L,J)
               IF (L .EQ. K) GO TO 20
                  AR(L,J) = AR(K,J)
                  AI(L,J) = AI(K,J)
                  AR(K,J) = TR
                  AI(K,J) = TI
   20          CONTINUE
               CALL WAXPY(N-K,TR,TI,AR(K+1,K),AI(K+1,K),1,AR(K+1,J),
     * AI(K+1,J),1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (CABS1(AR(N,N),AI(N,N)) .EQ. 0.0D0) INFO = N
      RETURN
      END
      SUBROUTINE WGESL(AR,AI,LDA,N,IPVT,BR,BI,JOB)
      INTEGER LDA,N,IPVT(1),JOB
      DOUBLE PRECISION AR(LDA,1),AI(LDA,1),BR(1),BI(1)
C
C     WGESL SOLVES THE DOUBLE-COMPLEX SYSTEM
C     A * X = B  OR  CTRANS(A) * X = B
C     USING THE FACTORS COMPUTED BY WGECO OR WGEFA.
C
C     ON ENTRY
C
C        A       DOUBLE-COMPLEX(LDA, N)
C                THE OUTPUT FROM WGECO OR WGEFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM WGECO OR WGEFA.
C
C        B       DOUBLE-COMPLEX(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C        JOB     INTEGER
C                = 0         TO SOLVE  A*X = B ,
C                = NONZERO   TO SOLVE  CTRANS(A)*X = B  WHERE
C         CTRANS(A)  IS THE CONJUGATE TRANSPOSE.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
C        CALLED CORRECTLY AND IF WGECO HAS SET RCOND .GT. 0.0
C        OR WGEFA HAS SET INFO .EQ. 0 .
C
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
C     WITH  P  COLUMNS
C           CALL WGECO(A,LDA,N,IPVT,RCOND,Z)
C           IF (RCOND IS TOO SMALL) GO TO ...
C           DO 10 J = 1, P
C              CALL WGESL(A,LDA,N,IPVT,C(1,J),0)
C        10 CONTINUE
C
C     LINPACK. THIS VERSION DATED 07/01/79 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS WAXPY,WDOTC
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION WDOTCR,WDOTCI,TR,TI
      INTEGER K,KB,L,NM1
C
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
C
C        JOB = 0 , SOLVE  A * X = B
C        FIRST SOLVE  L*Y = B
C
         IF (NM1 .LT. 1) GO TO 30
         DO 20 K = 1, NM1
            L = IPVT(K)
            TR = BR(L)
            TI = BI(L)
            IF (L .EQ. K) GO TO 10
               BR(L) = BR(K)
               BI(L) = BI(K)
               BR(K) = TR
               BI(K) = TI
   10       CONTINUE
            CALL WAXPY(N-K,TR,TI,AR(K+1,K),AI(K+1,K),1,BR(K+1),BI(K+1),
     *                 1)
   20    CONTINUE
   30    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            CALL WDIV(BR(K),BI(K),AR(K,K),AI(K,K),BR(K),BI(K))
            TR = -BR(K)
            TI = -BI(K)
            CALL WAXPY(K-1,TR,TI,AR(1,K),AI(1,K),1,BR(1),BI(1),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
C
C        JOB = NONZERO, SOLVE  CTRANS(A) * X = B
C        FIRST SOLVE  CTRANS(U)*Y = B
C
         DO 60 K = 1, N
            TR = BR(K) - WDOTCR(K-1,AR(1,K),AI(1,K),1,BR(1),BI(1),1)
            TI = BI(K) - WDOTCI(K-1,AR(1,K),AI(1,K),1,BR(1),BI(1),1)
            CALL WDIV(TR,TI,AR(K,K),-AI(K,K),BR(K),BI(K))
   60    CONTINUE
C
C        NOW SOLVE CTRANS(L)*X = Y
C
         IF (NM1 .LT. 1) GO TO 90
         DO 80 KB = 1, NM1
            K = N - KB
            BR(K) = BR(K)
     *            + WDOTCR(N-K,AR(K+1,K),AI(K+1,K),1,BR(K+1),BI(K+1),1)
            BI(K) = BI(K)
     *            + WDOTCI(N-K,AR(K+1,K),AI(K+1,K),1,BR(K+1),BI(K+1),1)
            L = IPVT(K)
            IF (L .EQ. K) GO TO 70
               TR = BR(L)
               TI = BI(L)
               BR(L) = BR(K)
               BI(L) = BI(K)
               BR(K) = TR
               BI(K) = TI
   70       CONTINUE
   80    CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END
      SUBROUTINE WGEDI(AR,AI,LDA,N,IPVT,DETR,DETI,WORKR,WORKI,JOB)
      INTEGER LDA,N,IPVT(1),JOB
      DOUBLE PRECISION AR(LDA,1),AI(LDA,1),DETR(2),DETI(2),WORKR(1),
     *                 WORKI(1)
C
C     WGEDI COMPUTES THE DETERMINANT AND INVERSE OF A MATRIX
C     USING THE FACTORS COMPUTED BY WGECO OR WGEFA.
C
C     ON ENTRY
C
C        A       DOUBLE-COMPLEX(LDA, N)
C                THE OUTPUT FROM WGECO OR WGEFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM WGECO OR WGEFA.
C
C        WORK    DOUBLE-COMPLEX(N)
C                WORK VECTOR.  CONTENTS DESTROYED.
C
C        JOB     INTEGER
C                = 11   BOTH DETERMINANT AND INVERSE.
C                = 01   INVERSE ONLY.
C                = 10   DETERMINANT ONLY.
C
C     ON RETURN
C
C        A       INVERSE OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE UNCHANGED.
C
C        DET     DOUBLE-COMPLEX(2)
C                DETERMINANT OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE NOT REFERENCED.
C                DETERMINANT = DET(1) * 10.0**DET(2)
C                WITH  1.0 .LE. CABS1(DET(1) .LT. 10.0
C                OR  DET(1) .EQ. 0.0 .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
C        A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED.
C        IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY
C        AND IF WGECO HAS SET RCOND .GT. 0.0 OR WGEFA HAS SET
C        INFO .EQ. 0 .
C
C     LINPACK. THIS VERSION DATED 07/01/79 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS WAXPY,WSCAL,WSWAP
C     FORTRAN DABS,MOD
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION TR,TI
      DOUBLE PRECISION TEN
      INTEGER I,J,K,KB,KP1,L,NM1
C
      DOUBLE PRECISION ZDUMR,ZDUMI
      DOUBLE PRECISION CABS1
      CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
C
C     COMPUTE DETERMINANT
C
      IF (JOB/10 .EQ. 0) GO TO 80
         DETR(1) = 1.0D0
         DETI(1) = 0.0D0
         DETR(2) = 0.0D0
         DETI(2) = 0.0D0
         TEN = 10.0D0
         DO 60 I = 1, N
            IF (IPVT(I) .EQ. I) GO TO 10
               DETR(1) = -DETR(1)
               DETI(1) = -DETI(1)
   10       CONTINUE
            CALL WMUL(AR(I,I),AI(I,I),DETR(1),DETI(1),DETR(1),DETI(1))
C           ...EXIT
C        ...EXIT
            IF (CABS1(DETR(1),DETI(1)) .EQ. 0.0D0) GO TO 70
   20       IF (CABS1(DETR(1),DETI(1)) .GE. 1.0D0) GO TO 30
               DETR(1) = TEN*DETR(1)
               DETI(1) = TEN*DETI(1)
               DETR(2) = DETR(2) - 1.0D0
               DETI(2) = DETI(2) - 0.0D0
            GO TO 20
   30       CONTINUE
   40       IF (CABS1(DETR(1),DETI(1)) .LT. TEN) GO TO 50
               DETR(1) = DETR(1)/TEN
               DETI(1) = DETI(1)/TEN
               DETR(2) = DETR(2) + 1.0D0
               DETI(2) = DETI(2) + 0.0D0
            GO TO 40
   50       CONTINUE
   60    CONTINUE
   70    CONTINUE
   80 CONTINUE
C
C     COMPUTE INVERSE(U)
C
      IF (MOD(JOB,10) .EQ. 0) GO TO 160
         DO 110 K = 1, N
            CALL WDIV(1.0D0,0.0D0,AR(K,K),AI(K,K),AR(K,K),AI(K,K))
            TR = -AR(K,K)
            TI = -AI(K,K)
            CALL WSCAL(K-1,TR,TI,AR(1,K),AI(1,K),1)
            KP1 = K + 1
            IF (N .LT. KP1) GO TO 100
            DO 90 J = KP1, N
               TR = AR(K,J)
               TI = AI(K,J)
               AR(K,J) = 0.0D0
               AI(K,J) = 0.0D0
               CALL WAXPY(K,TR,TI,AR(1,K),AI(1,K),1,AR(1,J),AI(1,J),1)
   90       CONTINUE
  100       CONTINUE
  110    CONTINUE
C
C        FORM INVERSE(U)*INVERSE(L)
C
         NM1 = N - 1
         IF (NM1 .LT. 1) GO TO 150
         DO 140 KB = 1, NM1
            K = N - KB
            KP1 = K + 1
            DO 120 I = KP1, N
               WORKR(I) = AR(I,K)
               WORKI(I) = AI(I,K)
               AR(I,K) = 0.0D0
               AI(I,K) = 0.0D0
  120       CONTINUE
            DO 130 J = KP1, N
               TR = WORKR(J)
               TI = WORKI(J)
               CALL WAXPY(N,TR,TI,AR(1,J),AI(1,J),1,AR(1,K),AI(1,K),1)
  130       CONTINUE
            L = IPVT(K)
            IF (L .NE. K)
     *         CALL WSWAP(N,AR(1,K),AI(1,K),1,AR(1,L),AI(1,L),1)
  140    CONTINUE
  150    CONTINUE
  160 CONTINUE
      RETURN
      END
      SUBROUTINE WPOFA(AR,AI,LDA,N,INFO)
      DOUBLE PRECISION AR(LDA,1),AI(LDA,1)
      DOUBLE PRECISION S,TR,TI,WDOTCR,WDOTCI
      DO 30 J = 1, N
         INFO = J
         S = 0.0D0
         JM1 = J-1
         IF (JM1 .LT. 1) GO TO 20
         DO 10 K = 1, JM1
            TR = AR(K,J)-WDOTCR(K-1,AR(1,K),AI(1,K),1,AR(1,J),AI(1,J),1)
            TI = AI(K,J)-WDOTCI(K-1,AR(1,K),AI(1,K),1,AR(1,J),AI(1,J),1)
            CALL WDIV(TR,TI,AR(K,K),AI(K,K),TR,TI)
            AR(K,J) = TR
            AI(K,J) = TI
            S = S + TR*TR + TI*TI
   10    CONTINUE
   20    CONTINUE
         S = AR(J,J) - S
         IF (S.LE.0.0D0 .OR. AI(J,J).NE.0.0D0) GO TO 40
         AR(J,J) = DSQRT(S)
   30 CONTINUE
      INFO = 0
   40 RETURN
      END
      SUBROUTINE RREF(AR,AI,LDA,M,N,EPS)
      DOUBLE PRECISION AR(LDA,1),AI(LDA,1),EPS,TOL,TR,TI,WASUM
      TOL = 0.0D0
      DO 10 J = 1, N
         TOL = DMAX1(TOL,WASUM(M,AR(1,J),AI(1,J),1))
   10 CONTINUE
      TOL = EPS*DFLOAT(2*MAX0(M,N))*TOL
      K = 1
      L = 1
   20 IF (K.GT.M .OR. L.GT.N) RETURN
      I = IWAMAX(M-K+1,AR(K,L),AI(K,L),1) + K-1
      IF (DABS(AR(I,L))+DABS(AI(I,L)) .GT. TOL) GO TO 30
         CALL WSET(M-K+1,0.0D0,0.0D0,AR(K,L),AI(K,L),1)
         L = L+1
         GO TO 20
   30 CALL WSWAP(N-L+1,AR(I,L),AI(I,L),LDA,AR(K,L),AI(K,L),LDA)
      CALL WDIV(1.0D0,0.0D0,AR(K,L),AI(K,L),TR,TI)
      CALL WSCAL(N-L+1,TR,TI,AR(K,L),AI(K,L),LDA)
      AR(K,L) = 1.0D0
      AI(K,L) = 0.0D0
      DO 40 I = 1, M
         TR = -AR(I,L)
         TI = -AI(I,L)
         IF (I .NE. K) CALL WAXPY(N-L+1,TR,TI,
     $                 AR(K,L),AI(K,L),LDA,AR(I,L),AI(I,L),LDA)
   40 CONTINUE
      K = K+1
      L = L+1
      GO TO 20
      END
      SUBROUTINE HILBER(A,LDA,N)
      DOUBLE PRECISION A(LDA,N)
C     GENERATE INVERSE HILBERT MATRIX
      DOUBLE PRECISION P,R
      P = DFLOAT(N)
      DO 20 I = 1, N
        IF (I.NE.1) P = (DFLOAT(N-I+1)*P*DFLOAT(N+I-1))/DFLOAT(I-1)**2
        R = P*P
        A(I,I) = R/DFLOAT(2*I-1)
        IF (I.EQ.N) GO TO 20
        IP1 = I+1
        DO 10 J = IP1, N
          R = -(DFLOAT(N-J+1)*R*(N+J-1))/DFLOAT(J-1)**2
          A(I,J) = R/DFLOAT(I+J-1)
          A(J,I) = A(I,J)
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE HTRIDI(NM,N,AR,AI,D,E,E2,TAU)
C
      INTEGER I,J,K,L,N,II,NM,JP1
      DOUBLE PRECISION AR(NM,N),AI(NM,N),D(N),E(N),E2(N),TAU(2,N)
      DOUBLE PRECISION F,G,H,FI,GI,HH,SI,SCALE
      DOUBLE PRECISION FLOP,PYTHAG
C
C     THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
C     THE ALGOL PROCEDURE TRED1, NUM. MATH. 11, 181-195(1968)
C     BY MARTIN, REINSCH, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     THIS SUBROUTINE REDUCES A COMPLEX HERMITIAN MATRIX
C     TO A REAL SYMMETRIC TRIDIAGONAL MATRIX USING
C     UNITARY SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT.
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.
C
C        N IS THE ORDER OF THE MATRIX.
C
C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE COMPLEX HERMITIAN INPUT MATRIX.
C          ONLY THE LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
C
C     ON OUTPUT.
C
C        AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
C          FORMATIONS USED IN THE REDUCTION IN THEIR FULL LOWER
C          TRIANGLES.  THEIR STRICT UPPER TRIANGLES AND THE
C          DIAGONAL OF AR ARE UNALTERED.
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX.
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO.
C
C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
C
C        TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
C
C     MODIFIED TO GET RID OF ALL COMPLEX ARITHMETIC, C. MOLER, 6/27/79.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
      TAU(1,N) = 1.0D0
      TAU(2,N) = 0.0D0
C
      DO 100 I = 1, N
  100 D(I) = AR(I,I)
C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
      DO 300 II = 1, N
         I = N + 1 - II
         L = I - 1
         H = 0.0D0
         SCALE = 0.0D0
         IF (L .LT. 1) GO TO 130
C     .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
         DO 120 K = 1, L
  120    SCALE = FLOP(SCALE + DABS(AR(I,K)) + DABS(AI(I,K)))
C
         IF (SCALE .NE. 0.0D0) GO TO 140
         TAU(1,L) = 1.0D0
         TAU(2,L) = 0.0D0
  130    E(I) = 0.0D0
         E2(I) = 0.0D0
         GO TO 290
C
  140    DO 150 K = 1, L
            AR(I,K) = FLOP(AR(I,K)/SCALE)
            AI(I,K) = FLOP(AI(I,K)/SCALE)
            H = FLOP(H + AR(I,K)*AR(I,K) + AI(I,K)*AI(I,K))
  150    CONTINUE
C
         E2(I) = FLOP(SCALE*SCALE*H)
         G = FLOP(DSQRT(H))
         E(I) = FLOP(SCALE*G)
         F = PYTHAG(AR(I,L),AI(I,L))
C     .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T ..........
         IF (F .EQ. 0.0D0) GO TO 160
         TAU(1,L) = FLOP((AI(I,L)*TAU(2,I) - AR(I,L)*TAU(1,I))/F)
         SI = FLOP((AR(I,L)*TAU(2,I) + AI(I,L)*TAU(1,I))/F)
         H = FLOP(H + F*G)
         G = FLOP(1.0D0 + G/F)
         AR(I,L) = FLOP(G*AR(I,L))
         AI(I,L) = FLOP(G*AI(I,L))
         IF (L .EQ. 1) GO TO 270
         GO TO 170
  160    TAU(1,L) = -TAU(1,I)
         SI = TAU(2,I)
         AR(I,L) = G
  170    F = 0.0D0
C
         DO 240 J = 1, L
            G = 0.0D0
            GI = 0.0D0
C     .......... FORM ELEMENT OF A*U ..........
            DO 180 K = 1, J
               G = FLOP(G + AR(J,K)*AR(I,K) + AI(J,K)*AI(I,K))
               GI = FLOP(GI - AR(J,K)*AI(I,K) + AI(J,K)*AR(I,K))
  180       CONTINUE
C
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
C
            DO 200 K = JP1, L
               G = FLOP(G + AR(K,J)*AR(I,K) - AI(K,J)*AI(I,K))
               GI = FLOP(GI - AR(K,J)*AI(I,K) - AI(K,J)*AR(I,K))
  200       CONTINUE
C     .......... FORM ELEMENT OF P ..........
  220       E(J) = FLOP(G/H)
            TAU(2,J) = FLOP(GI/H)
            F = FLOP(F + E(J)*AR(I,J) - TAU(2,J)*AI(I,J))
  240    CONTINUE
C
         HH = FLOP(F/(H + H))
C     .......... FORM REDUCED A ..........
         DO 260 J = 1, L
            F = AR(I,J)
            G = FLOP(E(J) - HH*F)
            E(J) = G
            FI = -AI(I,J)
            GI = FLOP(TAU(2,J) - HH*FI)
            TAU(2,J) = -GI
C
            DO 260 K = 1, J
               AR(J,K) = FLOP(AR(J,K) - F*E(K) - G*AR(I,K)
     X        + FI*TAU(2,K) + GI*AI(I,K))
               AI(J,K) = FLOP(AI(J,K) - F*TAU(2,K) - G*AI(I,K)
     X        - FI*E(K) - GI*AR(I,K))
  260    CONTINUE
C
  270    DO 280 K = 1, L
            AR(I,K) = FLOP(SCALE*AR(I,K))
            AI(I,K) = FLOP(SCALE*AI(I,K))
  280    CONTINUE
C
         TAU(2,L) = -SI
  290    HH = D(I)
         D(I) = AR(I,I)
         AR(I,I) = HH
         AI(I,I) = FLOP(SCALE*DSQRT(H))
  300 CONTINUE
C
      RETURN
      END
      SUBROUTINE HTRIBK(NM,N,AR,AI,TAU,M,ZR,ZI)
C
      INTEGER I,J,K,L,M,N,NM
      DOUBLE PRECISION AR(NM,N),AI(NM,N),TAU(2,N),ZR(NM,M),ZI(NM,M)
      DOUBLE PRECISION H,S,SI,FLOP
C
C     THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
C     THE ALGOL PROCEDURE TRBAK1, NUM. MATH. 11, 181-195(1968)
C     BY MARTIN, REINSCH, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN
C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
C     REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY  HTRIDI.
C
C     ON INPUT.
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.
C
C        N IS THE ORDER OF THE MATRIX.
C
C        AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
C          FORMATIONS USED IN THE REDUCTION BY  HTRIDI  IN THEIR
C          FULL LOWER TRIANGLES EXCEPT FOR THE DIAGONAL OF AR.
C
C        TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
C
C        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
C
C        ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
C          IN ITS FIRST M COLUMNS.
C
C     ON OUTPUT.
C
C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
C          IN THEIR FIRST M COLUMNS.
C
C     NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR
C     IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
      IF (M .EQ. 0) GO TO 200
C     .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC
C                TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN
C                TRIDIAGONAL MATRIX. ..........
      DO 50 K = 1, N
C
         DO 50 J = 1, M
            ZI(K,J) = FLOP(-ZR(K,J)*TAU(2,K))
            ZR(K,J) = FLOP(ZR(K,J)*TAU(1,K))
   50 CONTINUE
C
      IF (N .EQ. 1) GO TO 200
C     .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES ..........
      DO 140 I = 2, N
         L = I - 1
         H = AI(I,I)
         IF (H .EQ. 0.0D0) GO TO 140
C
         DO 130 J = 1, M
            S = 0.0D0
            SI = 0.0D0
C
            DO 110 K = 1, L
               S = FLOP(S + AR(I,K)*ZR(K,J) - AI(I,K)*ZI(K,J))
               SI = FLOP(SI + AR(I,K)*ZI(K,J) + AI(I,K)*ZR(K,J))
  110       CONTINUE
C     .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW ..........
            S = FLOP((S/H)/H)
            SI = FLOP((SI/H)/H)
C
            DO 120 K = 1, L
               ZR(K,J) = FLOP(ZR(K,J) - S*AR(I,K) - SI*AI(I,K))
               ZI(K,J) = FLOP(ZI(K,J) - SI*AR(I,K) + S*AI(I,K))
  120       CONTINUE
C
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE IMTQL2(NM,N,D,E,Z,IERR,JOB)
C
      INTEGER I,J,K,L,M,N,II,NM,MML,IERR
      DOUBLE PRECISION D(N),E(N),Z(NM,N)
      DOUBLE PRECISION B,C,F,G,P,R,S
      DOUBLE PRECISION FLOP
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL2,
C     NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON,
C     AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C     OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD.
C     THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
C     BE FOUND IF  TRED2  HAS BEEN USED TO REDUCE THIS
C     FULL MATRIX TO TRIDIAGONAL FORM.
C
C     ON INPUT.
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.
C
C        N IS THE ORDER OF THE MATRIX.
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY.
C
C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C          REDUCTION BY  TRED2, IF PERFORMED.  IF THE EIGENVECTORS
C          OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
C          THE IDENTITY MATRIX.
C
C      ON OUTPUT.
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
C          UNORDERED FOR INDICES 1,2,...,IERR-1.
C
C        E HAS BEEN DESTROYED.
C
C        Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
C          TRIDIAGONAL (OR FULL) MATRIX.  IF AN ERROR EXIT IS MADE,
C          Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
C          EIGENVALUES.
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C  DETERMINED AFTER 30 ITERATIONS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
C
C*****
C     MODIFIED BY C. MOLER TO ELIMINATE MACHEP 11/22/78
C     MODIFIED TO ADD JOB PARAMETER 08/27/79
C*****
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E(I-1) = E(I)
C
      E(N) = 0.0D0
C
      DO 240 L = 1, N
         J = 0
C     .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
  105    DO 110 M = L, N
            IF (M .EQ. N) GO TO 120
C*****
            P = FLOP(DABS(D(M)) + DABS(D(M+1)))
            S = FLOP(P + DABS(E(M)))
            IF (P .EQ. S) GO TO 120
C*****
  110    CONTINUE
C
  120    P = D(L)
         IF (M .EQ. L) GO TO 240
         IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     .......... FORM SHIFT ..........
         G = FLOP((D(L+1) - P)/(2.0D0*E(L)))
         R = FLOP(DSQRT(G*G+1.0D0))
         G = FLOP(D(M) - P + E(L)/(G + DSIGN(R,G)))
         S = 1.0D0
         C = 1.0D0
         P = 0.0D0
         MML = M - L
C     .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
         DO 200 II = 1, MML
            I = M - II
            F = FLOP(S*E(I))
            B = FLOP(C*E(I))
            IF (DABS(F) .LT. DABS(G)) GO TO 150
            C = FLOP(G/F)
            R = FLOP(DSQRT(C*C+1.0D0))
            E(I+1) = FLOP(F*R)
            S = FLOP(1.0D0/R)
            C = FLOP(C*S)
            GO TO 160
  150       S = FLOP(F/G)
            R = FLOP(DSQRT(S*S+1.0D0))
            E(I+1) = FLOP(G*R)
            C = FLOP(1.0D0/R)
            S = FLOP(S*C)
  160       G = FLOP(D(I+1) - P)
            R = FLOP((D(I) - G)*S + 2.0D0*C*B)
            P = FLOP(S*R)
            D(I+1) = G + P
            G = FLOP(C*R - B)
            IF (JOB .EQ. 0) GO TO 185
C     .......... FORM VECTOR ..........
            DO 180 K = 1, N
               F = Z(K,I+1)
               Z(K,I+1) = FLOP(S*Z(K,I) + C*F)
               Z(K,I) = FLOP(C*Z(K,I) - S*F)
  180       CONTINUE
  185       CONTINUE
C
  200    CONTINUE
C
         D(L) = FLOP(D(L) - P)
         E(L) = G
         E(M) = 0.0D0
         GO TO 105
  240 CONTINUE
C     .......... ORDER EIGENVALUES AND EIGENVECTORS ..........
      DO 300 II = 2, N
         I = II - 1
         K = I
         P = D(I)
C
         DO 260 J = II, N
            IF (D(J) .GE. P) GO TO 260
            K = J
            P = D(J)
  260    CONTINUE
C
         IF (K .EQ. I) GO TO 300
         D(K) = D(I)
         D(I) = P
C
         IF (JOB .EQ. 0) GO TO 285
         DO 280 J = 1, N
            P = Z(J,I)
            Z(J,I) = Z(J,K)
            Z(J,K) = P
  280    CONTINUE
  285    CONTINUE
C
  300 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS ..........
 1000 IERR = L
 1001 RETURN
      END
      SUBROUTINE CORTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
C
      INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
      DOUBLE PRECISION AR(NM,N),AI(NM,N),ORTR(IGH),ORTI(IGH)
      DOUBLE PRECISION F,G,H,FI,FR,SCALE
      DOUBLE PRECISION FLOP,PYTHAG
C
C     THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
C     THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
C     BY MARTIN AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C     GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
C     REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
C     LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
C     UNITARY SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT.
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.
C
C        N IS THE ORDER OF THE MATRIX.
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N.
C
C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
C
C     ON OUTPUT.
C
C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE HESSENBERG MATRIX.  INFORMATION
C          ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
C          IS STORED IN THE REMAINING TRIANGLES UNDER THE
C          HESSENBERG MATRIX.
C
C        ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
C          TRANSFORMATIONS.  ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C
      DO 180 M = KP1, LA
         H = 0.0D0
         ORTR(M) = 0.0D0
         ORTI(M) = 0.0D0
         SCALE = 0.0D0
C     .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
         DO 90 I = M, IGH
   90    SCALE = FLOP(SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1)))
C
         IF (SCALE .EQ. 0.0D0) GO TO 180
         MP = M + IGH
C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
         DO 100 II = M, IGH
            I = MP - II
            ORTR(I) = FLOP(AR(I,M-1)/SCALE)
            ORTI(I) = FLOP(AI(I,M-1)/SCALE)
            H = FLOP(H + ORTR(I)*ORTR(I) + ORTI(I)*ORTI(I))
  100    CONTINUE
C
         G = FLOP(DSQRT(H))
         F = PYTHAG(ORTR(M),ORTI(M))
         IF (F .EQ. 0.0D0) GO TO 103
         H = FLOP(H + F*G)
         G = FLOP(G/F)
         ORTR(M) = FLOP((1.0D0 + G)*ORTR(M))
         ORTI(M) = FLOP((1.0D0 + G)*ORTI(M))
         GO TO 105
C
  103    ORTR(M) = G
         AR(M,M-1) = SCALE
C     .......... FORM (I-(U*UT)/H)*A ..........
  105    DO 130 J = M, N
            FR = 0.0D0
            FI = 0.0D0
C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
            DO 110 II = M, IGH
               I = MP - II
               FR = FLOP(FR + ORTR(I)*AR(I,J) + ORTI(I)*AI(I,J))
               FI = FLOP(FI + ORTR(I)*AI(I,J) - ORTI(I)*AR(I,J))
  110       CONTINUE
C
            FR = FLOP(FR/H)
            FI = FLOP(FI/H)
C
            DO 120 I = M, IGH
               AR(I,J) = FLOP(AR(I,J) - FR*ORTR(I) + FI*ORTI(I))
               AI(I,J) = FLOP(AI(I,J) - FR*ORTI(I) - FI*ORTR(I))
  120       CONTINUE
C
  130    CONTINUE
C     .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
         DO 160 I = 1, IGH
            FR = 0.0D0
            FI = 0.0D0
C     .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
            DO 140 JJ = M, IGH
               J = MP - JJ
               FR = FLOP(FR + ORTR(J)*AR(I,J) - ORTI(J)*AI(I,J))
               FI = FLOP(FI + ORTR(J)*AI(I,J) + ORTI(J)*AR(I,J))
  140       CONTINUE
C
            FR = FLOP(FR/H)
            FI = FLOP(FI/H)
C
            DO 150 J = M, IGH
               AR(I,J) = FLOP(AR(I,J) - FR*ORTR(J) - FI*ORTI(J))
               AI(I,J) = FLOP(AI(I,J) + FR*ORTI(J) - FI*ORTR(J))
  150       CONTINUE
C
  160    CONTINUE
C
         ORTR(M) = FLOP(SCALE*ORTR(M))
         ORTI(M) = FLOP(SCALE*ORTI(M))
         AR(M,M-1) = FLOP(-G*AR(M,M-1))
         AI(M,M-1) = FLOP(-G*AI(M,M-1))
  180 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE COMQR3(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR
     *                 ,JOB)
C*****
C     MODIFICATION OF EISPACK COMQR2 TO ADD JOB PARAMETER
C     JOB = 0  OUTPUT H = SCHUR TRIANGULAR FORM, Z NOT USED
C         = 1  OUTPUT H = SCHUR FORM, Z = UNITARY SIMILARITY
C         = 2  SAME AS COMQR2
C         = 3  OUTPUT H = HESSENBERG FORM, Z = UNITARY SIMILARITY
C     ALSO ELIMINATE MACHEP
C     C. MOLER, 11/22/78 AND 09/14/80
C     OVERFLOW CONTROL IN EIGENVECTOR BACKSUBSTITUTION, 3/16/82
C*****
C
      INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
     X        ITN,ITS,LOW,LP1,ENM1,IEND,IERR
      DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N),
     X       ORTR(IGH),ORTI(IGH)
      DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM
      DOUBLE PRECISION FLOP,PYTHAG
C
C     THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
C     ALGOL PROCEDURE  COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
C     AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
C     THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
C     (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C     OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
C     METHOD.  THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
C     CAN ALSO BE FOUND IF  CORTH  HAS BEEN USED TO REDUCE
C     THIS GENERAL MATRIX TO HESSENBERG FORM.
C
C     ON INPUT.
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.
C
C        N IS THE ORDER OF THE MATRIX.
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N.
C
C        ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
C          FORMATIONS USED IN THE REDUCTION BY  CORTH, IF PERFORMED.
C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.  IF THE EIGENVECTORS
C          OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
C          ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
C
C        HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
C          THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
C          INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
C          REDUCTION BY  CORTH, IF PERFORMED.  IF THE EIGENVECTORS OF
C          THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
C          ARBITRARY.
C
C     ON OUTPUT.
C
C        ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
C          HAVE BEEN DESTROYED.
C
C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVALUES.  IF AN ERROR
C          EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C          FOR INDICES IERR+1,...,N.
C
C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVECTORS.  THE EIGENVECTORS
C          ARE UNNORMALIZED.  IF AN ERROR EXIT IS MADE, NONE OF
C          THE EIGENVECTORS HAS BEEN FOUND.
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C  DETERMINED AFTER A TOTAL OF 30*N ITERATIONS.
C
C     MODIFIED TO GET RID OF ALL COMPLEX ARITHMETIC, C. MOLER, 6/27/79.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
      IERR = 0
C*****
      IF (JOB .EQ. 0) GO TO 150
C*****
C     .......... INITIALIZE EIGENVECTOR MATRIX ..........
      DO 100 I = 1, N
C
         DO 100 J = 1, N
            ZR(I,J) = 0.0D0
            ZI(I,J) = 0.0D0
            IF (I .EQ. J) ZR(I,J) = 1.0D0
  100 CONTINUE
C     .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
C                FROM THE INFORMATION LEFT BY CORTH ..........
      IEND = IGH - LOW - 1
      IF (IEND) 180, 150, 105
C     .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
  105 DO 140 II = 1, IEND
         I = IGH - II
         IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GO TO 140
         IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GO TO 140
C     .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
         NORM = FLOP(HR(I,I-1)*ORTR(I) + HI(I,I-1)*ORTI(I))
         IP1 = I + 1
C
         DO 110 K = IP1, IGH
            ORTR(K) = HR(K,I-1)
            ORTI(K) = HI(K,I-1)
  110    CONTINUE
C
         DO 130 J = I, IGH
            SR = 0.0D0
            SI = 0.0D0
C
            DO 115 K = I, IGH
               SR = FLOP(SR + ORTR(K)*ZR(K,J) + ORTI(K)*ZI(K,J))
               SI = FLOP(SI + ORTR(K)*ZI(K,J) - ORTI(K)*ZR(K,J))
  115       CONTINUE
C
            SR = FLOP(SR/NORM)
            SI = FLOP(SI/NORM)
C
            DO 120 K = I, IGH
               ZR(K,J) = FLOP(ZR(K,J) + SR*ORTR(K) - SI*ORTI(K))
               ZI(K,J) = FLOP(ZI(K,J) + SR*ORTI(K) + SI*ORTR(K))
  120       CONTINUE
C
  130    CONTINUE
C
  140 CONTINUE
C*****
      IF (JOB .EQ. 3) GO TO 1001
C*****
C     .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
  150 L = LOW + 1
C
      DO 170 I = L, IGH
         LL = MIN0(I+1,IGH)
         IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170
         NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
         YR = FLOP(HR(I,I-1)/NORM)
         YI = FLOP(HI(I,I-1)/NORM)
         HR(I,I-1) = NORM
         HI(I,I-1) = 0.0D0
C
         DO 155 J = I, N
            SI = FLOP(YR*HI(I,J) - YI*HR(I,J))
            HR(I,J) = FLOP(YR*HR(I,J) + YI*HI(I,J))
            HI(I,J) = SI
  155    CONTINUE
C
         DO 160 J = 1, LL
            SI = FLOP(YR*HI(J,I) + YI*HR(J,I))
            HR(J,I) = FLOP(YR*HR(J,I) - YI*HI(J,I))
            HI(J,I) = SI
  160    CONTINUE
C*****
         IF (JOB .EQ. 0) GO TO 170
C*****
         DO 165 J = LOW, IGH
            SI = FLOP(YR*ZI(J,I) + YI*ZR(J,I))
            ZR(J,I) = FLOP(YR*ZR(J,I) - YI*ZI(J,I))
            ZI(J,I) = SI
  165    CONTINUE
C
  170 CONTINUE
C     .......... STORE ROOTS ISOLATED BY CBAL ..........
  180 DO 200 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
         WR(I) = HR(I,I)
         WI(I) = HI(I,I)
  200 CONTINUE
C
      EN = IGH
      TR = 0.0D0
      TI = 0.0D0
      ITN = 30*N
C     .......... SEARCH FOR NEXT EIGENVALUE ..........
  220 IF (EN .LT. LOW) GO TO 680
      ITS = 0
      ENM1 = EN - 1
C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
  240 DO 260 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 300
C*****
         XR = FLOP(DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
     X             + DABS(HR(L,L)) +DABS(HI(L,L)))
         YR = FLOP(XR + DABS(HR(L,L-1)))
         IF (XR .EQ. YR) GO TO 300
C*****
  260 CONTINUE
C     .......... FORM SHIFT ..........
  300 IF (L .EQ. EN) GO TO 660
      IF (ITN .EQ. 0) GO TO 1000
      IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
      SR = HR(EN,EN)
      SI = HI(EN,EN)
      XR = FLOP(HR(ENM1,EN)*HR(EN,ENM1))
      XI = FLOP(HI(ENM1,EN)*HR(EN,ENM1))
      IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340
      YR = FLOP((HR(ENM1,ENM1) - SR)/2.0D0)
      YI = FLOP((HI(ENM1,ENM1) - SI)/2.0D0)
      CALL WSQRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
      IF (YR*ZZR + YI*ZZI .GE. 0.0D0) GO TO 310
      ZZR = -ZZR
      ZZI = -ZZI
  310 CALL WDIV(XR,XI,YR+ZZR,YI+ZZI,ZZR,ZZI)
      SR = FLOP(SR - ZZR)
      SI = FLOP(SI - ZZI)
      GO TO 340
C     .......... FORM EXCEPTIONAL SHIFT ..........
  320 SR = FLOP(DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2)))
      SI = 0.0D0
C
  340 DO 360 I = LOW, EN
         HR(I,I) = FLOP(HR(I,I) - SR)
         HI(I,I) = FLOP(HI(I,I) - SI)
  360 CONTINUE
C
      TR = FLOP(TR + SR)
      TI = FLOP(TI + SI)
      ITS = ITS + 1
      ITN = ITN - 1
C     .......... REDUCE TO TRIANGLE (ROWS) ..........
      LP1 = L + 1
C
      DO 500 I = LP1, EN
         SR = HR(I,I-1)
         HR(I,I-1) = 0.0D0
         NORM = FLOP(DABS(HR(I-1,I-1)) + DABS(HI(I-1,I-1)) + DABS(SR))
         NORM = FLOP(NORM*DSQRT((HR(I-1,I-1)/NORM)**2 +
     X  (HI(I-1,I-1)/NORM)**2 + (SR/NORM)**2))
         XR = FLOP(HR(I-1,I-1)/NORM)
         WR(I-1) = XR
         XI = FLOP(HI(I-1,I-1)/NORM)
         WI(I-1) = XI
         HR(I-1,I-1) = NORM
         HI(I-1,I-1) = 0.0D0
         HI(I,I-1) = FLOP(SR/NORM)
C
         DO 490 J = I, N
            YR = HR(I-1,J)
            YI = HI(I-1,J)
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            HR(I-1,J) = FLOP(XR*YR + XI*YI + HI(I,I-1)*ZZR)
            HI(I-1,J) = FLOP(XR*YI - XI*YR + HI(I,I-1)*ZZI)
            HR(I,J) = FLOP(XR*ZZR - XI*ZZI - HI(I,I-1)*YR)
            HI(I,J) = FLOP(XR*ZZI + XI*ZZR - HI(I,I-1)*YI)
  490    CONTINUE
C
  500 CONTINUE
C
      SI = HI(EN,EN)
      IF (SI .EQ. 0.0D0) GO TO 540
      NORM = PYTHAG(HR(EN,EN),SI)
      SR = FLOP(HR(EN,EN)/NORM)
      SI = FLOP(SI/NORM)
      HR(EN,EN) = NORM
      HI(EN,EN) = 0.0D0
      IF (EN .EQ. N) GO TO 540
      IP1 = EN + 1
C
      DO 520 J = IP1, N
         YR = HR(EN,J)
         YI = HI(EN,J)
         HR(EN,J) = FLOP(SR*YR + SI*YI)
         HI(EN,J) = FLOP(SR*YI - SI*YR)
  520 CONTINUE
C     .......... INVERSE OPERATION (COLUMNS) ..........
  540 DO 600 J = LP1, EN
         XR = WR(J-1)
         XI = WI(J-1)
C
         DO 580 I = 1, J
            YR = HR(I,J-1)
            YI = 0.0D0
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            IF (I .EQ. J) GO TO 560
            YI = HI(I,J-1)
            HI(I,J-1) = FLOP(XR*YI + XI*YR + HI(J,J-1)*ZZI)
  560       HR(I,J-1) = FLOP(XR*YR - XI*YI + HI(J,J-1)*ZZR)
            HR(I,J) = FLOP(XR*ZZR + XI*ZZI - HI(J,J-1)*YR)
            HI(I,J) = FLOP(XR*ZZI - XI*ZZR - HI(J,J-1)*YI)
  580    CONTINUE
C*****
         IF (JOB .EQ. 0) GO TO 600
C*****
         DO 590 I = LOW, IGH
            YR = ZR(I,J-1)
            YI = ZI(I,J-1)
            ZZR = ZR(I,J)
            ZZI = ZI(I,J)
            ZR(I,J-1) = FLOP(XR*YR - XI*YI + HI(J,J-1)*ZZR)
            ZI(I,J-1) = FLOP(XR*YI + XI*YR + HI(J,J-1)*ZZI)
            ZR(I,J) = FLOP(XR*ZZR + XI*ZZI - HI(J,J-1)*YR)
            ZI(I,J) = FLOP(XR*ZZI - XI*ZZR - HI(J,J-1)*YI)
  590    CONTINUE
C
  600 CONTINUE
C
      IF (SI .EQ. 0.0D0) GO TO 240
C
      DO 630 I = 1, EN
         YR = HR(I,EN)
         YI = HI(I,EN)
         HR(I,EN) = FLOP(SR*YR - SI*YI)
         HI(I,EN) = FLOP(SR*YI + SI*YR)
  630 CONTINUE
C*****
      IF (JOB .EQ. 0) GO TO 240
C*****
      DO 640 I = LOW, IGH
         YR = ZR(I,EN)
         YI = ZI(I,EN)
         ZR(I,EN) = FLOP(SR*YR - SI*YI)
         ZI(I,EN) = FLOP(SR*YI + SI*YR)
  640 CONTINUE
C
      GO TO 240
C     .......... A ROOT FOUND ..........
  660 HR(EN,EN) = FLOP(HR(EN,EN) + TR)
      WR(EN) = HR(EN,EN)
      HI(EN,EN) = FLOP(HI(EN,EN) + TI)
      WI(EN) = HI(EN,EN)
      EN = ENM1
      GO TO 220
C     .......... ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
C                VECTORS OF UPPER TRIANGULAR FORM ..........
C
C*****  THE FOLLOWING SECTION CHANGED FOR OVERFLOW CONTROL
C       C. MOLER, 3/16/82
C
  680 IF (JOB .NE. 2) GO TO 1001
C
      NORM = 0.0D0
      DO 720 I = 1, N
         DO 720 J = I, N
            TR = FLOP(DABS(HR(I,J))) + FLOP(DABS(HI(I,J)))
            IF (TR .GT. NORM) NORM = TR
  720 CONTINUE
      IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GO TO 1001
C     .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
      DO 800 NN = 2, N
         EN = N + 2 - NN
         XR = WR(EN)
         XI = WI(EN)
         HR(EN,EN) = 1.0D0
         HI(EN,EN) = 0.0D0
         ENM1 = EN - 1
C     .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
         DO 780 II = 1, ENM1
            I = EN - II
            ZZR = 0.0D0
            ZZI = 0.0D0
            IP1 = I + 1
            DO 740 J = IP1, EN
               ZZR = FLOP(ZZR + HR(I,J)*HR(J,EN) - HI(I,J)*HI(J,EN))
               ZZI = FLOP(ZZI + HR(I,J)*HI(J,EN) + HI(I,J)*HR(J,EN))
  740       CONTINUE
            YR = FLOP(XR - WR(I))
            YI = FLOP(XI - WI(I))
            IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GO TO 765
               YR = NORM
  760          YR = FLOP(YR/100.0D0)
               YI = FLOP(NORM + YR)
               IF (YI .NE. NORM) GO TO 760
               YI = 0.0D0
  765       CONTINUE
            CALL WDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
            TR = FLOP(DABS(HR(I,EN))) + FLOP(DABS(HI(I,EN)))
            IF (TR .EQ. 0.0D0) GO TO 780
            IF (TR + 1.0D0/TR .GT. TR) GO TO 780
            DO 770 J = I, EN
               HR(J,EN) = FLOP(HR(J,EN)/TR)
               HI(J,EN) = FLOP(HI(J,EN)/TR)
  770       CONTINUE
  780    CONTINUE
C
  800 CONTINUE
C*****
C     .......... END BACKSUBSTITUTION ..........
      ENM1 = N - 1
C     .......... VECTORS OF ISOLATED ROOTS ..........
      DO  840 I = 1, ENM1
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
         IP1 = I + 1
C
         DO 820 J = IP1, N
            ZR(I,J) = HR(I,J)
            ZI(I,J) = HI(I,J)
  820    CONTINUE
C
  840 CONTINUE
C     .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
C                VECTORS OF ORIGINAL FULL MATRIX.
C                FOR J=N STEP -1 UNTIL LOW+1 DO -- ..........
      DO 880 JJ = LOW, ENM1
         J = N + LOW - JJ
         M = MIN0(J,IGH)
C
         DO 880 I = LOW, IGH
            ZZR = 0.0D0
            ZZI = 0.0D0
C
            DO 860 K = LOW, M
               ZZR = FLOP(ZZR + ZR(I,K)*HR(K,J) - ZI(I,K)*HI(K,J))
               ZZI = FLOP(ZZI + ZR(I,K)*HI(K,J) + ZI(I,K)*HR(K,J))
  860       CONTINUE
C
            ZR(I,J) = ZZR
            ZI(I,J) = ZZI
  880 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS ..........
 1000 IERR = EN
 1001 RETURN
      END
      SUBROUTINE WSVDC(XR,XI,LDX,N,P,SR,SI,ER,EI,UR,UI,LDU,VR,VI,LDV,
     *                 WORKR,WORKI,JOB,INFO)
      INTEGER LDX,N,P,LDU,LDV,JOB,INFO
      DOUBLE PRECISION XR(LDX,1),XI(LDX,1),SR(1),SI(1),ER(1),EI(1),
     *                 UR(LDU,1),UI(LDU,1),VR(LDV,1),VI(LDV,1),
     *                 WORKR(1),WORKI(1)
C
C
C     WSVDC IS A SUBROUTINE TO REDUCE A DOUBLE-COMPLEX NXP MATRIX X BY
C     UNITARY TRANSFORMATIONS U AND V TO DIAGONAL FORM.  THE
C     DIAGONAL ELEMENTS S(I) ARE THE SINGULAR VALUES OF X.  THE
C     COLUMNS OF U ARE THE CORRESPONDING LEFT SINGULAR VECTORS,
C     AND THE COLUMNS OF V THE RIGHT SINGULAR VECTORS.
C
C     ON ENTRY
C
C         X         DOUBLE-COMPLEX(LDX,P), WHERE LDX.GE.N.
C                   X CONTAINS THE MATRIX WHOSE SINGULAR VALUE
C                   DECOMPOSITION IS TO BE COMPUTED.  X IS
C                   DESTROYED BY WSVDC.
C
C         LDX       INTEGER.
C                   LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C
C         N         INTEGER.
C                   N IS THE NUMBER OF COLUMNS OF THE MATRIX X.
C
C         P         INTEGER.
C                   P IS THE NUMBER OF ROWS OF THE MATRIX X.
C
C         LDU       INTEGER.
C                   LDU IS THE LEADING DIMENSION OF THE ARRAY U
C                   (SEE BELOW).
C
C         LDV       INTEGER.
C                   LDV IS THE LEADING DIMENSION OF THE ARRAY V
C                   (SEE BELOW).
C
C         WORK      DOUBLE-COMPLEX(N).
C                   WORK IS A SCRATCH ARRAY.
C
C         JOB       INTEGER.
C                   JOB CONTROLS THE COMPUTATION OF THE SINGULAR
C                   VECTORS.  IT HAS THE DECIMAL EXPANSION AB
C                   WITH THE FOLLOWING MEANING
C
C     A.EQ.0    DO NOT COMPUTE THE LEFT SINGULAR
C               VECTORS.
C     A.EQ.1    RETURN THE N LEFT SINGULAR VECTORS
C               IN U.
C     A.GE.2    RETURNS THE FIRST MIN(N,P)
C               LEFT SINGULAR VECTORS IN U.
C     B.EQ.0    DO NOT COMPUTE THE RIGHT SINGULAR
C               VECTORS.
C     B.EQ.1    RETURN THE RIGHT SINGULAR VECTORS
C               IN V.
C
C     ON RETURN
C
C         S         DOUBLE-COMPLEX(MM), WHERE MM=MIN(N+1,P).
C                   THE FIRST MIN(N,P) ENTRIES OF S CONTAIN THE
C                   SINGULAR VALUES OF X ARRANGED IN DESCENDING
C                   ORDER OF MAGNITUDE.
C
C         E         DOUBLE-COMPLEX(P).
C                   E ORDINARILY CONTAINS ZEROS.  HOWEVER SEE THE
C                   DISCUSSION OF INFO FOR EXCEPTIONS.
C
C         U         DOUBLE-COMPLEX(LDU,K), WHERE LDU.GE.N.
C                   IF JOBA.EQ.1 THEN K.EQ.N,
C                   IF JOBA.EQ.2 THEN K.EQ.MIN(N,P).
C                   U CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS.
C                   U IS NOT REFERENCED IF JOBA.EQ.0.  IF N.LE.P
C                   OR IF JOBA.GT.2, THEN U MAY BE IDENTIFIED WITH X
C                   IN THE SUBROUTINE CALL.
C
C         V         DOUBLE-COMPLEX(LDV,P), WHERE LDV.GE.P.
C                   V CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS.
C                   V IS NOT REFERENCED IF JOBB.EQ.0.  IF P.LE.N,
C                   THEN V MAY BE IDENTIFIED WHTH X IN THE
C                   SUBROUTINE CALL.
C
C         INFO      INTEGER.
C                   THE SINGULAR VALUES (AND THEIR CORRESPONDING
C                   SINGULAR VECTORS) S(INFO+1),S(INFO+2),...,S(M)
C                   ARE CORRECT (HERE M=MIN(N,P)).  THUS IF
C                   INFO.EQ.0, ALL THE SINGULAR VALUES AND THEIR
C                   VECTORS ARE CORRECT.  IN ANY EVENT, THE MATRIX
C                   B = CTRANS(U)*X*V IS THE BIDIAGONAL MATRIX
C                   WITH THE ELEMENTS OF S ON ITS DIAGONAL AND THE
C                   ELEMENTS OF E ON ITS SUPER-DIAGONAL (CTRANS(U)
C                   IS THE CONJUGATE-TRANSPOSE OF U).  THUS THE
C                   SINGULAR VALUES OF X AND B ARE THE SAME.
C
C     LINPACK. THIS VERSION DATED 07/03/79 .
C     G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C
C     WSVDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
C
C     BLAS WAXPY,PYTHAG,WDOTCR,WDOTCI,WSCAL,WSWAP,WNRM2,RROTG
C     FORTRAN DABS,DIMAG,DMAX1
C     FORTRAN MAX0,MIN0,MOD,DSQRT
C
C     INTERNAL VARIABLES
C
      INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT,
     *        MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1
      DOUBLE PRECISION PYTHAG,WDOTCR,WDOTCI,TR,TI,RR,RI
      DOUBLE PRECISION B,C,CS,EL,EMM1,F,G,WNRM2,SCALE,SHIFT,SL,SM,SN,
     *                 SMM1,T1,TEST,ZTEST,SMALL,FLOP
      LOGICAL WANTU,WANTV
C
      DOUBLE PRECISION ZDUMR,ZDUMI
      DOUBLE PRECISION CABS1
      CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
C
C     SET THE MAXIMUM NUMBER OF ITERATIONS.
C
      MAXIT = 75
C
C     SMALL NUMBER, ROUGHLY MACHINE EPSILON, USED TO AVOID UNDERFLOW
C
      SMALL = 1.D0/2.D0**48
C
C     DETERMINE WHAT IS TO BE COMPUTED.
C
      WANTU = .FALSE.
      WANTV = .FALSE.
      JOBU = MOD(JOB,100)/10
      NCU = N
      IF (JOBU .GT. 1) NCU = MIN0(N,P)
      IF (JOBU .NE. 0) WANTU = .TRUE.
      IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE.
C
C     REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS
C     IN S AND THE SUPER-DIAGONAL ELEMENTS IN E.
C
      INFO = 0
      NCT = MIN0(N-1,P)
      NRT = MAX0(0,MIN0(P-2,N))
      LU = MAX0(NCT,NRT)
      IF (LU .LT. 1) GO TO 190
      DO 180 L = 1, LU
         LP1 = L + 1
         IF (L .GT. NCT) GO TO 30
C
C           COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND
C           PLACE THE L-TH DIAGONAL IN S(L).
C
            SR(L) = WNRM2(N-L+1,XR(L,L),XI(L,L),1)
            SI(L) = 0.0D0
            IF (CABS1(SR(L),SI(L)) .EQ. 0.0D0) GO TO 20
               IF (CABS1(XR(L,L),XI(L,L)) .EQ. 0.0D0) GO TO 10
                  CALL WSIGN(SR(L),SI(L),XR(L,L),XI(L,L),SR(L),SI(L))
   10          CONTINUE
               CALL WDIV(1.0D0,0.0D0,SR(L),SI(L),TR,TI)
               CALL WSCAL(N-L+1,TR,TI,XR(L,L),XI(L,L),1)
               XR(L,L) = FLOP(1.0D0 + XR(L,L))
   20       CONTINUE
            SR(L) = -SR(L)
            SI(L) = -SI(L)
   30    CONTINUE
         IF (P .LT. LP1) GO TO 60
         DO 50 J = LP1, P
            IF (L .GT. NCT) GO TO 40
            IF (CABS1(SR(L),SI(L)) .EQ. 0.0D0) GO TO 40
C
C              APPLY THE TRANSFORMATION.
C
               TR = -WDOTCR(N-L+1,XR(L,L),XI(L,L),1,XR(L,J),XI(L,J),1)
               TI = -WDOTCI(N-L+1,XR(L,L),XI(L,L),1,XR(L,J),XI(L,J),1)
               CALL WDIV(TR,TI,XR(L,L),XI(L,L),TR,TI)
               CALL WAXPY(N-L+1,TR,TI,XR(L,L),XI(L,L),1,XR(L,J),
     * XI(L,J),1)
   40       CONTINUE
C
C           PLACE THE L-TH ROW OF X INTO  E FOR THE
C           SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION.
C
            ER(J) = XR(L,J)
            EI(J) = -XI(L,J)
   50    CONTINUE
   60    CONTINUE
         IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 80
C
C           PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK
C           MULTIPLICATION.
C
            DO 70 I = L, N
               UR(I,L) = XR(I,L)
               UI(I,L) = XI(I,L)
   70       CONTINUE
   80    CONTINUE
         IF (L .GT. NRT) GO TO 170
C
C           COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE
C           L-TH SUPER-DIAGONAL IN E(L).
C
            ER(L) = WNRM2(P-L,ER(LP1),EI(LP1),1)
            EI(L) = 0.0D0
            IF (CABS1(ER(L),EI(L)) .EQ. 0.0D0) GO TO 100
               IF (CABS1(ER(LP1),EI(LP1)) .EQ. 0.0D0) GO TO 90
                  CALL WSIGN(ER(L),EI(L),ER(LP1),EI(LP1),ER(L),EI(L))
   90          CONTINUE
               CALL WDIV(1.0D0,0.0D0,ER(L),EI(L),TR,TI)
               CALL WSCAL(P-L,TR,TI,ER(LP1),EI(LP1),1)
               ER(LP1) = FLOP(1.0D0 + ER(LP1))
  100       CONTINUE
            ER(L) = -ER(L)
            EI(L) = +EI(L)
            IF (LP1 .GT. N .OR. CABS1(ER(L),EI(L)) .EQ. 0.0D0)
     *         GO TO 140
C
C              APPLY THE TRANSFORMATION.
C
               DO 110 I = LP1, N
                  WORKR(I) = 0.0D0
                  WORKI(I) = 0.0D0
  110          CONTINUE
               DO 120 J = LP1, P
                  CALL WAXPY(N-L,ER(J),EI(J),XR(LP1,J),XI(LP1,J),1,
     *    WORKR(LP1),WORKI(LP1),1)
  120          CONTINUE
               DO 130 J = LP1, P
                  CALL WDIV(-ER(J),-EI(J),ER(LP1),EI(LP1),TR,TI)
                  CALL WAXPY(N-L,TR,-TI,WORKR(LP1),WORKI(LP1),1,
     *    XR(LP1,J),XI(LP1,J),1)
  130          CONTINUE
  140       CONTINUE
            IF (.NOT.WANTV) GO TO 160
C
C              PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT
C              BACK MULTIPLICATION.
C
               DO 150 I = LP1, P
                  VR(I,L) = ER(I)
                  VI(I,L) = EI(I)
  150          CONTINUE
  160       CONTINUE
  170    CONTINUE
  180 CONTINUE
  190 CONTINUE
C
C     SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M.
C
      M = MIN0(P,N+1)
      NCTP1 = NCT + 1
      NRTP1 = NRT + 1
      IF (NCT .GE. P) GO TO 200
         SR(NCTP1) = XR(NCTP1,NCTP1)
         SI(NCTP1) = XI(NCTP1,NCTP1)
  200 CONTINUE
      IF (N .GE. M) GO TO 210
         SR(M) = 0.0D0
         SI(M) = 0.0D0
  210 CONTINUE
      IF (NRTP1 .GE. M) GO TO 220
         ER(NRTP1) = XR(NRTP1,M)
         EI(NRTP1) = XI(NRTP1,M)
  220 CONTINUE
      ER(M) = 0.0D0
      EI(M) = 0.0D0
C
C     IF REQUIRED, GENERATE U.
C
      IF (.NOT.WANTU) GO TO 350
         IF (NCU .LT. NCTP1) GO TO 250
         DO 240 J = NCTP1, NCU
            DO 230 I = 1, N
               UR(I,J) = 0.0D0
               UI(I,J) = 0.0D0
  230       CONTINUE
            UR(J,J) = 1.0D0
            UI(J,J) = 0.0D0
  240    CONTINUE
  250    CONTINUE
         IF (NCT .LT. 1) GO TO 340
         DO 330 LL = 1, NCT
            L = NCT - LL + 1
            IF (CABS1(SR(L),SI(L)) .EQ. 0.0D0) GO TO 300
               LP1 = L + 1
               IF (NCU .LT. LP1) GO TO 270
               DO 260 J = LP1, NCU
                  TR = -WDOTCR(N-L+1,UR(L,L),UI(L,L),1,UR(L,J),
     *      UI(L,J),1)
                  TI = -WDOTCI(N-L+1,UR(L,L),UI(L,L),1,UR(L,J),
     *      UI(L,J),1)
                  CALL WDIV(TR,TI,UR(L,L),UI(L,L),TR,TI)
                  CALL WAXPY(N-L+1,TR,TI,UR(L,L),UI(L,L),1,UR(L,J),
     *    UI(L,J),1)
  260          CONTINUE
  270          CONTINUE
               CALL WRSCAL(N-L+1,-1.0D0,UR(L,L),UI(L,L),1)
               UR(L,L) = FLOP(1.0D0 + UR(L,L))
               LM1 = L - 1
               IF (LM1 .LT. 1) GO TO 290
               DO 280 I = 1, LM1
                  UR(I,L) = 0.0D0
                  UI(I,L) = 0.0D0
  280          CONTINUE
  290          CONTINUE
            GO TO 320
  300       CONTINUE
               DO 310 I = 1, N
                  UR(I,L) = 0.0D0
                  UI(I,L) = 0.0D0
  310          CONTINUE
               UR(L,L) = 1.0D0
               UI(L,L) = 0.0D0
  320       CONTINUE
  330    CONTINUE
  340    CONTINUE
  350 CONTINUE
C
C     IF IT IS REQUIRED, GENERATE V.
C
      IF (.NOT.WANTV) GO TO 400
         DO 390 LL = 1, P
            L = P - LL + 1
            LP1 = L + 1
            IF (L .GT. NRT) GO TO 370
            IF (CABS1(ER(L),EI(L)) .EQ. 0.0D0) GO TO 370
               DO 360 J = LP1, P
                  TR = -WDOTCR(P-L,VR(LP1,L),VI(LP1,L),1,VR(LP1,J),
     *      VI(LP1,J),1)
                  TI = -WDOTCI(P-L,VR(LP1,L),VI(LP1,L),1,VR(LP1,J),
     *      VI(LP1,J),1)
                  CALL WDIV(TR,TI,VR(LP1,L),VI(LP1,L),TR,TI)
                  CALL WAXPY(P-L,TR,TI,VR(LP1,L),VI(LP1,L),1,VR(LP1,J),
     *    VI(LP1,J),1)
  360          CONTINUE
  370       CONTINUE
            DO 380 I = 1, P
               VR(I,L) = 0.0D0
               VI(I,L) = 0.0D0
  380       CONTINUE
            VR(L,L) = 1.0D0
            VI(L,L) = 0.0D0
  390    CONTINUE
  400 CONTINUE
C
C     TRANSFORM S AND E SO THAT THEY ARE REAL.
C
      DO 420 I = 1, M
            TR = PYTHAG(SR(I),SI(I))
            IF (TR .EQ. 0.0D0) GO TO 405
            RR = SR(I)/TR
            RI = SI(I)/TR
            SR(I) = TR
            SI(I) = 0.0D0
            IF (I .LT. M) CALL WDIV(ER(I),EI(I),RR,RI,ER(I),EI(I))
            IF (WANTU) CALL WSCAL(N,RR,RI,UR(1,I),UI(1,I),1)
  405    CONTINUE
C     ...EXIT
         IF (I .EQ. M) GO TO 430
            TR = PYTHAG(ER(I),EI(I))
            IF (TR .EQ. 0.0D0) GO TO 410
            CALL WDIV(TR,0.0D0,ER(I),EI(I),RR,RI)
            ER(I) = TR
            EI(I) = 0.0D0
            CALL WMUL(SR(I+1),SI(I+1),RR,RI,SR(I+1),SI(I+1))
            IF (WANTV) CALL WSCAL(P,RR,RI,VR(1,I+1),VI(1,I+1),1)
  410    CONTINUE
  420 CONTINUE
  430 CONTINUE
C
C     MAIN ITERATION LOOP FOR THE SINGULAR VALUES.
C
      MM = M
      ITER = 0
  440 CONTINUE
C
C        QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND.
C
C     ...EXIT
         IF (M .EQ. 0) GO TO 700
C
C        IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET
C        FLAG AND RETURN.
C
         IF (ITER .LT. MAXIT) GO TO 450
            INFO = M
C     ......EXIT
            GO TO 700
  450    CONTINUE
C
C        THIS SECTION OF THE PROGRAM INSPECTS FOR
C        NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS.  ON
C        COMPLETION THE VARIABLE KASE IS SET AS FOLLOWS.
C
C           KASE = 1     IF SR(M) AND ER(L-1) ARE NEGLIGIBLE AND L.LT.M
C           KASE = 2     IF SR(L) IS NEGLIGIBLE AND L.LT.M
C           KASE = 3     IF ER(L-1) IS NEGLIGIBLE, L.LT.M, AND
C     SR(L), ..., SR(M) ARE NOT NEGLIGIBLE (QR STEP).
C           KASE = 4     IF ER(M-1) IS NEGLIGIBLE (CONVERGENCE).
C
         DO 470 LL = 1, M
            L = M - LL
C        ...EXIT
            IF (L .EQ. 0) GO TO 480
            TEST = FLOP(DABS(SR(L)) + DABS(SR(L+1)))
            ZTEST = FLOP(TEST + DABS(ER(L))/2.0D0)
            IF (SMALL*ZTEST .NE. SMALL*TEST) GO TO 460
               ER(L) = 0.0D0
C        ......EXIT
               GO TO 480
  460       CONTINUE
  470    CONTINUE
  480    CONTINUE
         IF (L .NE. M - 1) GO TO 490
            KASE = 4
         GO TO 560
  490    CONTINUE
            LP1 = L + 1
            MP1 = M + 1
            DO 510 LLS = LP1, MP1
               LS = M - LLS + LP1
C           ...EXIT
               IF (LS .EQ. L) GO TO 520
               TEST = 0.0D0
               IF (LS .NE. M) TEST = FLOP(TEST + DABS(ER(LS)))
               IF (LS .NE. L + 1) TEST = FLOP(TEST + DABS(ER(LS-1)))
               ZTEST = FLOP(TEST + DABS(SR(LS))/2.0D0)
               IF (SMALL*ZTEST .NE. SMALL*TEST) GO TO 500
                  SR(LS) = 0.0D0
C           ......EXIT
                  GO TO 520
  500          CONTINUE
  510       CONTINUE
  520       CONTINUE
            IF (LS .NE. L) GO TO 530
               KASE = 3
            GO TO 550
  530       CONTINUE
            IF (LS .NE. M) GO TO 540
               KASE = 1
            GO TO 550
  540       CONTINUE
               KASE = 2
               L = LS
  550       CONTINUE
  560    CONTINUE
         L = L + 1
C
C        PERFORM THE TASK INDICATED BY KASE.
C
         GO TO (570, 600, 620, 650), KASE
C
C        DEFLATE NEGLIGIBLE SR(M).
C
  570    CONTINUE
            MM1 = M - 1
            F = ER(M-1)
            ER(M-1) = 0.0D0
            DO 590 KK = L, MM1
               K = MM1 - KK + L
               T1 = SR(K)
               CALL RROTG(T1,F,CS,SN)
               SR(K) = T1
               IF (K .EQ. L) GO TO 580
                  F = FLOP(-SN*ER(K-1))
                  ER(K-1) = FLOP(CS*ER(K-1))
  580          CONTINUE
               IF (WANTV) CALL RROT(P,VR(1,K),1,VR(1,M),1,CS,SN)
               IF (WANTV) CALL RROT(P,VI(1,K),1,VI(1,M),1,CS,SN)
  590       CONTINUE
         GO TO 690
C
C        SPLIT AT NEGLIGIBLE SR(L).
C
  600    CONTINUE
            F = ER(L-1)
            ER(L-1) = 0.0D0
            DO 610 K = L, M
               T1 = SR(K)
               CALL RROTG(T1,F,CS,SN)
               SR(K) = T1
               F = FLOP(-SN*ER(K))
               ER(K) = FLOP(CS*ER(K))
               IF (WANTU) CALL RROT(N,UR(1,K),1,UR(1,L-1),1,CS,SN)
               IF (WANTU) CALL RROT(N,UI(1,K),1,UI(1,L-1),1,CS,SN)
  610       CONTINUE
         GO TO 690
C
C        PERFORM ONE QR STEP.
C
  620    CONTINUE
C
C           CALCULATE THE SHIFT.
C
            SCALE = DMAX1(DABS(SR(M)),DABS(SR(M-1)),DABS(ER(M-1)),
     * DABS(SR(L)),DABS(ER(L)))
            SM = SR(M)/SCALE
            SMM1 = SR(M-1)/SCALE
            EMM1 = ER(M-1)/SCALE
            SL = SR(L)/SCALE
            EL = ER(L)/SCALE
            B = FLOP(((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0D0)
            C = FLOP((SM*EMM1)**2)
            SHIFT = 0.0D0
            IF (B .EQ. 0.0D0 .AND. C .EQ. 0.0D0) GO TO 630
               SHIFT = FLOP(DSQRT(B**2+C))
               IF (B .LT. 0.0D0) SHIFT = -SHIFT
               SHIFT = FLOP(C/(B + SHIFT))
  630       CONTINUE
            F = FLOP((SL + SM)*(SL - SM) - SHIFT)
            G = FLOP(SL*EL)
C
C           CHASE ZEROS.
C
            MM1 = M - 1
            DO 640 K = L, MM1
               CALL RROTG(F,G,CS,SN)
               IF (K .NE. L) ER(K-1) = F
               F = FLOP(CS*SR(K) + SN*ER(K))
               ER(K) = FLOP(CS*ER(K) - SN*SR(K))
               G = FLOP(SN*SR(K+1))
               SR(K+1) = FLOP(CS*SR(K+1))
               IF (WANTV) CALL RROT(P,VR(1,K),1,VR(1,K+1),1,CS,SN)
               IF (WANTV) CALL RROT(P,VI(1,K),1,VI(1,K+1),1,CS,SN)
               CALL RROTG(F,G,CS,SN)
               SR(K) = F
               F = FLOP(CS*ER(K) + SN*SR(K+1))
               SR(K+1) = FLOP(-SN*ER(K) + CS*SR(K+1))
               G = FLOP(SN*ER(K+1))
               ER(K+1) = FLOP(CS*ER(K+1))
               IF (WANTU .AND. K .LT. N)
     *            CALL RROT(N,UR(1,K),1,UR(1,K+1),1,CS,SN)
               IF (WANTU .AND. K .LT. N)
     *            CALL RROT(N,UI(1,K),1,UI(1,K+1),1,CS,SN)
  640       CONTINUE
            ER(M-1) = F
            ITER = ITER + 1
         GO TO 690
C
C        CONVERGENCE
C
  650    CONTINUE
C
C           MAKE THE SINGULAR VALUE  POSITIVE
C
            IF (SR(L) .GE. 0.0D0) GO TO 660
               SR(L) = -SR(L)
             IF (WANTV) CALL WRSCAL(P,-1.0D0,VR(1,L),VI(1,L),1)
  660       CONTINUE
C
C           ORDER THE SINGULAR VALUE.
C
  670       IF (L .EQ. MM) GO TO 680
C           ...EXIT
               IF (SR(L) .GE. SR(L+1)) GO TO 680
               TR = SR(L)
               SR(L) = SR(L+1)
               SR(L+1) = TR
               IF (WANTV .AND. L .LT. P)
     *            CALL WSWAP(P,VR(1,L),VI(1,L),1,VR(1,L+1),VI(1,L+1),1)
               IF (WANTU .AND. L .LT. N)
     *            CALL WSWAP(N,UR(1,L),UI(1,L),1,UR(1,L+1),UI(1,L+1),1)
               L = L + 1
            GO TO 670
  680       CONTINUE
            ITER = 0
            M = M - 1
  690    CONTINUE
      GO TO 440
  700 CONTINUE
      RETURN
      END
      SUBROUTINE WQRDC(XR,XI,LDX,N,P,QRAUXR,QRAUXI,JPVT,WORKR,WORKI,
     *                 JOB)
      INTEGER LDX,N,P,JOB
      INTEGER JPVT(1)
      DOUBLE PRECISION XR(LDX,1),XI(LDX,1),QRAUXR(1),QRAUXI(1),
     *                 WORKR(1),WORKI(1)
C
C     WQRDC USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR
C     FACTORIZATION OF AN N BY P MATRIX X.  COLUMN PIVOTING
C     BASED ON THE 2-NORMS OF THE REDUCED COLUMNS MAY BE
C     PERFORMED AT THE USERS OPTION.
C
C     ON ENTRY
C
C        X       DOUBLE-COMPLEX(LDX,P), WHERE LDX .GE. N.
C                X CONTAINS THE MATRIX WHOSE DECOMPOSITION IS TO BE
C                COMPUTED.
C
C        LDX     INTEGER.
C                LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C
C        N       INTEGER.
C                N IS THE NUMBER OF ROWS OF THE MATRIX X.
C
C        P       INTEGER.
C                P IS THE NUMBER OF COLUMNS OF THE MATRIX X.
C
C        JPVT    INTEGER(P).
C                JPVT CONTAINS INTEGERS THAT CONTROL THE SELECTION
C                OF THE PIVOT COLUMNS.  THE K-TH COLUMN X(K) OF X
C                IS PLACED IN ONE OF THREE CLASSES ACCORDING TO THE
C                VALUE OF JPVT(K).
C
C                   IF JPVT(K) .GT. 0, THEN X(K) IS AN INITIAL
C                   COLUMN.
C
C                   IF JPVT(K) .EQ. 0, THEN X(K) IS A FREE COLUMN.
C
C                   IF JPVT(K) .LT. 0, THEN X(K) IS A FINAL COLUMN.
C
C                BEFORE THE DECOMPOSITION IS COMPUTED, INITIAL COLUMNS
C                ARE MOVED TO THE BEGINNING OF THE ARRAY X AND FINAL
C                COLUMNS TO THE END.  BOTH INITIAL AND FINAL COLUMNS
C                ARE FROZEN IN PLACE DURING THE COMPUTATION AND ONLY
C                FREE COLUMNS ARE MOVED.  AT THE K-TH STAGE OF THE
C                REDUCTION, IF X(K) IS OCCUPIED BY A FREE COLUMN
C                IT IS INTERCHANGED WITH THE FREE COLUMN OF LARGEST
C                REDUCED NORM.  JPVT IS NOT REFERENCED IF
C                JOB .EQ. 0.
C
C        WORK    DOUBLE-COMPLEX(P).
C                WORK IS A WORK ARRAY.  WORK IS NOT REFERENCED IF
C                JOB .EQ. 0.
C
C        JOB     INTEGER.
C                JOB IS AN INTEGER THAT INITIATES COLUMN PIVOTING.
C                IF JOB .EQ. 0, NO PIVOTING IS DONE.
C                IF JOB .NE. 0, PIVOTING IS DONE.
C
C     ON RETURN
C
C        X       X CONTAINS IN ITS UPPER TRIANGLE THE UPPER
C                TRIANGULAR MATRIX R OF THE QR FACTORIZATION.
C                BELOW ITS DIAGONAL X CONTAINS INFORMATION FROM
C                WHICH THE UNITARY PART OF THE DECOMPOSITION
C                CAN BE RECOVERED.  NOTE THAT IF PIVOTING HAS
C                BEEN REQUESTED, THE DECOMPOSITION IS NOT THAT
C                OF THE ORIGINAL MATRIX X BUT THAT OF X
C                WITH ITS COLUMNS PERMUTED AS DESCRIBED BY JPVT.
C
C        QRAUX   DOUBLE-COMPLEX(P).
C                QRAUX CONTAINS FURTHER INFORMATION REQUIRED TO RECOVER
C                THE UNITARY PART OF THE DECOMPOSITION.
C
C        JPVT    JPVT(K) CONTAINS THE INDEX OF THE COLUMN OF THE
C                ORIGINAL MATRIX THAT HAS BEEN INTERCHANGED INTO
C                THE K-TH COLUMN, IF PIVOTING WAS REQUESTED.
C
C     LINPACK. THIS VERSION DATED 07/03/79 .
C     G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C
C     WQRDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
C
C     BLAS WAXPY,PYTHAG,WDOTCR,WDOTCI,WSCAL,WSWAP,WNRM2
C     FORTRAN DABS,DIMAG,DMAX1,MIN0
C
C     INTERNAL VARIABLES
C
      INTEGER J,JP,L,LP1,LUP,MAXJ,PL,PU
      DOUBLE PRECISION MAXNRM,WNRM2,TT
      DOUBLE PRECISION PYTHAG,WDOTCR,WDOTCI,NRMXLR,NRMXLI,TR,TI,FLOP
      LOGICAL NEGJ,SWAPJ
C
      DOUBLE PRECISION ZDUMR,ZDUMI
      DOUBLE PRECISION CABS1
      CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
C
      PL = 1
      PU = 0
      IF (JOB .EQ. 0) GO TO 60
C
C        PIVOTING HAS BEEN REQUESTED.  REARRANGE THE COLUMNS
C        ACCORDING TO JPVT.
C
         DO 20 J = 1, P
            SWAPJ = JPVT(J) .GT. 0
            NEGJ = JPVT(J) .LT. 0
            JPVT(J) = J
            IF (NEGJ) JPVT(J) = -J
            IF (.NOT.SWAPJ) GO TO 10
               IF (J .NE. PL)
     *            CALL WSWAP(N,XR(1,PL),XI(1,PL),1,XR(1,J),XI(1,J),1)
               JPVT(J) = JPVT(PL)
               JPVT(PL) = J
               PL = PL + 1
   10       CONTINUE
   20    CONTINUE
         PU = P
         DO 50 JJ = 1, P
            J = P - JJ + 1
            IF (JPVT(J) .GE. 0) GO TO 40
               JPVT(J) = -JPVT(J)
               IF (J .EQ. PU) GO TO 30
                  CALL WSWAP(N,XR(1,PU),XI(1,PU),1,XR(1,J),XI(1,J),1)
                  JP = JPVT(PU)
                  JPVT(PU) = JPVT(J)
                  JPVT(J) = JP
   30          CONTINUE
               PU = PU - 1
   40       CONTINUE
   50    CONTINUE
   60 CONTINUE
C
C     COMPUTE THE NORMS OF THE FREE COLUMNS.
C
      IF (PU .LT. PL) GO TO 80
      DO 70 J = PL, PU
         QRAUXR(J) = WNRM2(N,XR(1,J),XI(1,J),1)
         QRAUXI(J) = 0.0D0
         WORKR(J) = QRAUXR(J)
         WORKI(J) = QRAUXI(J)
   70 CONTINUE
   80 CONTINUE
C
C     PERFORM THE HOUSEHOLDER REDUCTION OF X.
C
      LUP = MIN0(N,P)
      DO 210 L = 1, LUP
         IF (L .LT. PL .OR. L .GE. PU) GO TO 120
C
C           LOCATE THE COLUMN OF LARGEST NORM AND BRING IT
C           INTO THE PIVOT POSITION.
C
            MAXNRM = 0.0D0
            MAXJ = L
            DO 100 J = L, PU
               IF (QRAUXR(J) .LE. MAXNRM) GO TO 90
                  MAXNRM = QRAUXR(J)
                  MAXJ = J
   90          CONTINUE
  100       CONTINUE
            IF (MAXJ .EQ. L) GO TO 110
               CALL WSWAP(N,XR(1,L),XI(1,L),1,XR(1,MAXJ),XI(1,MAXJ),1)
               QRAUXR(MAXJ) = QRAUXR(L)
               QRAUXI(MAXJ) = QRAUXI(L)
               WORKR(MAXJ) = WORKR(L)
               WORKI(MAXJ) = WORKI(L)
               JP = JPVT(MAXJ)
               JPVT(MAXJ) = JPVT(L)
               JPVT(L) = JP
  110       CONTINUE
  120    CONTINUE
         QRAUXR(L) = 0.0D0
         QRAUXI(L) = 0.0D0
         IF (L .EQ. N) GO TO 200
C
C           COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L.
C
            NRMXLR = WNRM2(N-L+1,XR(L,L),XI(L,L),1)
            NRMXLI = 0.0D0
            IF (CABS1(NRMXLR,NRMXLI) .EQ. 0.0D0) GO TO 190
               IF (CABS1(XR(L,L),XI(L,L)) .EQ. 0.0D0) GO TO 130
                 CALL WSIGN(NRMXLR,NRMXLI,XR(L,L),XI(L,L),NRMXLR,NRMXLI)
  130          CONTINUE
               CALL WDIV(1.0D0,0.0D0,NRMXLR,NRMXLI,TR,TI)
               CALL WSCAL(N-L+1,TR,TI,XR(L,L),XI(L,L),1)
               XR(L,L) = FLOP(1.0D0 + XR(L,L))
C
C              APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS,
C              UPDATING THE NORMS.
C
               LP1 = L + 1
               IF (P .LT. LP1) GO TO 180
               DO 170 J = LP1, P
                  TR = -WDOTCR(N-L+1,XR(L,L),XI(L,L),1,XR(L,J),
     *      XI(L,J),1)
                  TI = -WDOTCI(N-L+1,XR(L,L),XI(L,L),1,XR(L,J),
     *      XI(L,J),1)
                  CALL WDIV(TR,TI,XR(L,L),XI(L,L),TR,TI)
                  CALL WAXPY(N-L+1,TR,TI,XR(L,L),XI(L,L),1,XR(L,J),
     *    XI(L,J),1)
                  IF (J .LT. PL .OR. J .GT. PU) GO TO 160
                  IF (CABS1(QRAUXR(J),QRAUXI(J)) .EQ. 0.0D0)
     *               GO TO 160
                    TT = 1.0D0 - (PYTHAG(XR(L,J),XI(L,J))/QRAUXR(J))**2
                    TT = DMAX1(TT,0.0D0)
                    TR = FLOP(TT)
                    TT = FLOP(1.0D0+0.05D0*TT*(QRAUXR(J)/WORKR(J))**2)
                    IF (TT .EQ. 1.0D0) GO TO 140
                     QRAUXR(J) = QRAUXR(J)*DSQRT(TR)
                     QRAUXI(J) = QRAUXI(J)*DSQRT(TR)
                     GO TO 150
  140                CONTINUE
      QRAUXR(J) = WNRM2(N-L,XR(L+1,J),XI(L+1,J),1)
      QRAUXI(J) = 0.0D0
      WORKR(J) = QRAUXR(J)
      WORKI(J) = QRAUXI(J)
  150                CONTINUE
  160             CONTINUE
  170          CONTINUE
  180          CONTINUE
C
C              SAVE THE TRANSFORMATION.
C
               QRAUXR(L) = XR(L,L)
               QRAUXI(L) = XI(L,L)
               XR(L,L) = -NRMXLR
               XI(L,L) = -NRMXLI
  190       CONTINUE
  200    CONTINUE
  210 CONTINUE
      RETURN
      END
      SUBROUTINE WQRSL(XR,XI,LDX,N,K,QRAUXR,QRAUXI,YR,YI,QYR,QYI,QTYR,
     *                 QTYI,BR,BI,RSDR,RSDI,XBR,XBI,JOB,INFO)
      INTEGER LDX,N,K,JOB,INFO
      DOUBLE PRECISION XR(LDX,1),XI(LDX,1),QRAUXR(1),QRAUXI(1),YR(1),
     *                 YI(1),QYR(1),QYI(1),QTYR(1),QTYI(1),BR(1),BI(1),
     *                 RSDR(1),RSDI(1),XBR(1),XBI(1)
C
C     WQRSL APPLIES THE OUTPUT OF WQRDC TO COMPUTE COORDINATE
C     TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS.
C     FOR K .LE. MIN(N,P), LET XK BE THE MATRIX
C
C            XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K)))
C
C     FORMED FROM COLUMNNS JPVT(1), ... ,JPVT(K) OF THE ORIGINAL
C     N X P MATRIX X THAT WAS INPUT TO WQRDC (IF NO PIVOTING WAS
C     DONE, XK CONSISTS OF THE FIRST K COLUMNS OF X IN THEIR
C     ORIGINAL ORDER).  WQRDC PRODUCES A FACTORED UNITARY MATRIX Q
C     AND AN UPPER TRIANGULAR MATRIX R SUCH THAT
C
C              XK = Q * (R)
C    (0)
C
C     THIS INFORMATION IS CONTAINED IN CODED FORM IN THE ARRAYS
C     X AND QRAUX.
C
C     ON ENTRY
C
C        X      DOUBLE-COMPLEX(LDX,P).
C               X CONTAINS THE OUTPUT OF WQRDC.
C
C        LDX    INTEGER.
C               LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C
C        N      INTEGER.
C               N IS THE NUMBER OF ROWS OF THE MATRIX XK.  IT MUST
C               HAVE THE SAME VALUE AS N IN WQRDC.
C
C        K      INTEGER.
C               K IS THE NUMBER OF COLUMNS OF THE MATRIX XK.  K
C               MUST NNOT BE GREATER THAN MIN(N,P), WHERE P IS THE
C               SAME AS IN THE CALLING SEQUENCE TO WQRDC.
C
C        QRAUX  DOUBLE-COMPLEX(P).
C               QRAUX CONTAINS THE AUXILIARY OUTPUT FROM WQRDC.
C
C        Y      DOUBLE-COMPLEX(N)
C               Y CONTAINS AN N-VECTOR THAT IS TO BE MANIPULATED
C               BY WQRSL.
C
C        JOB    INTEGER.
C               JOB SPECIFIES WHAT IS TO BE COMPUTED.  JOB HAS
C               THE DECIMAL EXPANSION ABCDE, WITH THE FOLLOWING
C               MEANING.
C
C IF A.NE.0, COMPUTE QY.
C IF B,C,D, OR E .NE. 0, COMPUTE QTY.
C IF C.NE.0, COMPUTE B.
C IF D.NE.0, COMPUTE RSD.
C IF E.NE.0, COMPUTE XB.
C
C               NOTE THAT A REQUEST TO COMPUTE B, RSD, OR XB
C               AUTOMATICALLY TRIGGERS THE COMPUTATION OF QTY, FOR
C               WHICH AN ARRAY MUST BE PROVIDED IN THE CALLING
C               SEQUENCE.
C
C     ON RETURN
C
C        QY     DOUBLE-COMPLEX(N).
C               QY CONNTAINS Q*Y, IF ITS COMPUTATION HAS BEEN
C               REQUESTED.
C
C        QTY    DOUBLE-COMPLEX(N).
C               QTY CONTAINS CTRANS(Q)*Y, IF ITS COMPUTATION HAS
C               BEEN REQUESTED.  HERE CTRANS(Q) IS THE CONJUGATE
C               TRANSPOSE OF THE MATRIX Q.
C
C        B      DOUBLE-COMPLEX(K)
C               B CONTAINS THE SOLUTION OF THE LEAST SQUARES PROBLEM
C
C MINIMIZE NORM2(Y - XK*B),
C
C               IF ITS COMPUTATION HAS BEEN REQUESTED.  (NOTE THAT
C               IF PIVOTING WAS REQUESTED IN WQRDC, THE J-TH
C               COMPONENT OF B WILL BE ASSOCIATED WITH COLUMN JPVT(J)
C               OF THE ORIGINAL MATRIX X THAT WAS INPUT INTO WQRDC.)
C
C        RSD    DOUBLE-COMPLEX(N).
C               RSD CONTAINS THE LEAST SQUARES RESIDUAL Y - XK*B,
C               IF ITS COMPUTATION HAS BEEN REQUESTED.  RSD IS
C               ALSO THE ORTHOGONAL PROJECTION OF Y ONTO THE
C               ORTHOGONAL COMPLEMENT OF THE COLUMN SPACE OF XK.
C
C        XB     DOUBLE-COMPLEX(N).
C               XB CONTAINS THE LEAST SQUARES APPROXIMATION XK*B,
C               IF ITS COMPUTATION HAS BEEN REQUESTED.  XB IS ALSO
C               THE ORTHOGONAL PROJECTION OF Y ONTO THE COLUMN SPACE
C               OF X.
C
C        INFO   INTEGER.
C               INFO IS ZERO UNLESS THE COMPUTATION OF B HAS
C               BEEN REQUESTED AND R IS EXACTLY SINGULAR.  IN
C               THIS CASE, INFO IS THE INDEX OF THE FIRST ZERO
C               DIAGONAL ELEMENT OF R AND B IS LEFT UNALTERED.
C
C     THE PARAMETERS QY, QTY, B, RSD, AND XB ARE NOT REFERENCED
C     IF THEIR COMPUTATION IS NOT REQUESTED AND IN THIS CASE
C     CAN BE REPLACED BY DUMMY VARIABLES IN THE CALLING PROGRAM.
C     TO SAVE STORAGE, THE USER MAY IN SOME CASES USE THE SAME
C     ARRAY FOR DIFFERENT PARAMETERS IN THE CALLING SEQUENCE.  A
C     FREQUENTLY OCCURING EXAMPLE IS WHEN ONE WISHES TO COMPUTE
C     ANY OF B, RSD, OR XB AND DOES NOT NEED Y OR QTY.  IN THIS
C     CASE ONE MAY IDENTIFY Y, QTY, AND ONE OF B, RSD, OR XB, WHILE
C     PROVIDING SEPARATE ARRAYS FOR ANYTHING ELSE THAT IS TO BE
C     COMPUTED.  THUS THE CALLING SEQUENCE
C
C          CALL WQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO)
C
C     WILL RESULT IN THE COMPUTATION OF B AND RSD, WITH RSD
C     OVERWRITING Y.  MORE GENERALLY, EACH ITEM IN THE FOLLOWING
C     LIST CONTAINS GROUPS OF PERMISSIBLE IDENTIFICATIONS FOR
C     A SINGLE CALLINNG SEQUENCE.
C
C          1. (Y,QTY,B) (RSD) (XB) (QY)
C
C          2. (Y,QTY,RSD) (B) (XB) (QY)
C
C          3. (Y,QTY,XB) (B) (RSD) (QY)
C
C          4. (Y,QY) (QTY,B) (RSD) (XB)
C
C          5. (Y,QY) (QTY,RSD) (B) (XB)
C
C          6. (Y,QY) (QTY,XB) (B) (RSD)
C
C     IN ANY GROUP THE VALUE RETURNED IN THE ARRAY ALLOCATED TO
C     THE GROUP CORRESPONDS TO THE LAST MEMBER OF THE GROUP.
C
C     LINPACK. THIS VERSION DATED 07/03/79 .
C     G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C
C     WQRSL USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
C
C     BLAS WAXPY,WCOPY,WDOTCR,WDOTCI
C     FORTRAN DABS,DIMAG,MIN0,MOD
C
C     INTERNAL VARIABLES
C
      INTEGER I,J,JJ,JU,KP1
      DOUBLE PRECISION WDOTCR,WDOTCI,TR,TI,TEMPR,TEMPI
      LOGICAL CB,CQY,CQTY,CR,CXB
C
      DOUBLE PRECISION ZDUMR,ZDUMI
      DOUBLE PRECISION CABS1
      CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
C
C     SET INFO FLAG.
C
      INFO = 0
C
C     DETERMINE WHAT IS TO BE COMPUTED.
C
      CQY = JOB/10000 .NE. 0
      CQTY = MOD(JOB,10000) .NE. 0
      CB = MOD(JOB,1000)/100 .NE. 0
      CR = MOD(JOB,100)/10 .NE. 0
      CXB = MOD(JOB,10) .NE. 0
      JU = MIN0(K,N-1)
C
C     SPECIAL ACTION WHEN N=1.
C
      IF (JU .NE. 0) GO TO 80
         IF (.NOT.CQY) GO TO 10
            QYR(1) = YR(1)
            QYI(1) = YI(1)
   10    CONTINUE
         IF (.NOT.CQTY) GO TO 20
            QTYR(1) = YR(1)
            QTYI(1) = YI(1)
   20    CONTINUE
         IF (.NOT.CXB) GO TO 30
            XBR(1) = YR(1)
            XBI(1) = YI(1)
   30    CONTINUE
         IF (.NOT.CB) GO TO 60
            IF (CABS1(XR(1,1),XI(1,1)) .NE. 0.0D0) GO TO 40
               INFO = 1
            GO TO 50
   40       CONTINUE
               CALL WDIV(YR(1),YI(1),XR(1,1),XI(1,1),BR(1),BI(1))
   50       CONTINUE
   60    CONTINUE
         IF (.NOT.CR) GO TO 70
            RSDR(1) = 0.0D0
            RSDI(1) = 0.0D0
   70    CONTINUE
      GO TO 290
   80 CONTINUE
C
C        SET UP TO COMPUTE QY OR QTY.
C
         IF (CQY) CALL WCOPY(N,YR,YI,1,QYR,QYI,1)
         IF (CQTY) CALL WCOPY(N,YR,YI,1,QTYR,QTYI,1)
         IF (.NOT.CQY) GO TO 110
C
C           COMPUTE QY.
C
            DO 100 JJ = 1, JU
               J = JU - JJ + 1
               IF (CABS1(QRAUXR(J),QRAUXI(J)) .EQ. 0.0D0)
     *            GO TO 90
                  TEMPR = XR(J,J)
                  TEMPI = XI(J,J)
                  XR(J,J) = QRAUXR(J)
                  XI(J,J) = QRAUXI(J)
                  TR = -WDOTCR(N-J+1,XR(J,J),XI(J,J),1,QYR(J),QYI(J),1)
                  TI = -WDOTCI(N-J+1,XR(J,J),XI(J,J),1,QYR(J),QYI(J),1)
                  CALL WDIV(TR,TI,XR(J,J),XI(J,J),TR,TI)
                  CALL WAXPY(N-J+1,TR,TI,XR(J,J),XI(J,J),1,QYR(J),
     *    QYI(J),1)
                  XR(J,J) = TEMPR
                  XI(J,J) = TEMPI
   90          CONTINUE
  100       CONTINUE
  110    CONTINUE
         IF (.NOT.CQTY) GO TO 140
C
C           COMPUTE CTRANS(Q)*Y.
C
            DO 130 J = 1, JU
               IF (CABS1(QRAUXR(J),QRAUXI(J)) .EQ. 0.0D0)
     *            GO TO 120
                  TEMPR = XR(J,J)
                  TEMPI = XI(J,J)
                  XR(J,J) = QRAUXR(J)
                  XI(J,J) = QRAUXI(J)
                  TR = -WDOTCR(N-J+1,XR(J,J),XI(J,J),1,QTYR(J),
     *      QTYI(J),1)
                  TI = -WDOTCI(N-J+1,XR(J,J),XI(J,J),1,QTYR(J),
     *      QTYI(J),1)
                  CALL WDIV(TR,TI,XR(J,J),XI(J,J),TR,TI)
                  CALL WAXPY(N-J+1,TR,TI,XR(J,J),XI(J,J),1,QTYR(J),
     *    QTYI(J),1)
                  XR(J,J) = TEMPR
                  XI(J,J) = TEMPI
  120          CONTINUE
  130       CONTINUE
  140    CONTINUE
C
C        SET UP TO COMPUTE B, RSD, OR XB.
C
         IF (CB) CALL WCOPY(K,QTYR,QTYI,1,BR,BI,1)
         KP1 = K + 1
         IF (CXB) CALL WCOPY(K,QTYR,QTYI,1,XBR,XBI,1)
         IF (CR .AND. K .LT. N)
     *      CALL WCOPY(N-K,QTYR(KP1),QTYI(KP1),1,RSDR(KP1),RSDI(KP1),1)
         IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 160
            DO 150 I = KP1, N
               XBR(I) = 0.0D0
               XBI(I) = 0.0D0
  150       CONTINUE
  160    CONTINUE
         IF (.NOT.CR) GO TO 180
            DO 170 I = 1, K
               RSDR(I) = 0.0D0
               RSDI(I) = 0.0D0
  170       CONTINUE
  180    CONTINUE
         IF (.NOT.CB) GO TO 230
C
C           COMPUTE B.
C
            DO 210 JJ = 1, K
               J = K - JJ + 1
               IF (CABS1(XR(J,J),XI(J,J)) .NE. 0.0D0) GO TO 190
                  INFO = J
C                 ......EXIT
C           ......EXIT
                  GO TO 220
  190          CONTINUE
               CALL WDIV(BR(J),BI(J),XR(J,J),XI(J,J),BR(J),BI(J))
               IF (J .EQ. 1) GO TO 200
                  TR = -BR(J)
                  TI = -BI(J)
                  CALL WAXPY(J-1,TR,TI,XR(1,J),XI(1,J),1,BR,BI,1)
  200          CONTINUE
  210       CONTINUE
  220       CONTINUE
  230    CONTINUE
         IF (.NOT.CR .AND. .NOT.CXB) GO TO 280
C
C           COMPUTE RSD OR XB AS REQUIRED.
C
            DO 270 JJ = 1, JU
               J = JU - JJ + 1
               IF (CABS1(QRAUXR(J),QRAUXI(J)) .EQ. 0.0D0)
     *            GO TO 260
                  TEMPR = XR(J,J)
                  TEMPI = XI(J,J)
                  XR(J,J) = QRAUXR(J)
                  XI(J,J) = QRAUXI(J)
                  IF (.NOT.CR) GO TO 240
                  TR = -WDOTCR(N-J+1,XR(J,J),XI(J,J),1,RSDR(J),
     *         RSDI(J),1)
                  TI = -WDOTCI(N-J+1,XR(J,J),XI(J,J),1,RSDR(J),
     *         RSDI(J),1)
                  CALL WDIV(TR,TI,XR(J,J),XI(J,J),TR,TI)
                  CALL WAXPY(N-J+1,TR,TI,XR(J,J),XI(J,J),1,RSDR(J),
     *       RSDI(J),1)
  240             CONTINUE
                  IF (.NOT.CXB) GO TO 250
                   TR = -WDOTCR(N-J+1,XR(J,J),XI(J,J),1,XBR(J),
     *         XBI(J),1)
                   TI = -WDOTCI(N-J+1,XR(J,J),XI(J,J),1,XBR(J),
     *         XBI(J),1)
                   CALL WDIV(TR,TI,XR(J,J),XI(J,J),TR,TI)
                   CALL WAXPY(N-J+1,TR,TI,XR(J,J),XI(J,J),1,XBR(J),
     *       XBI(J),1)
  250             CONTINUE
                  XR(J,J) = TEMPR
                  XI(J,J) = TEMPI
  260          CONTINUE
  270       CONTINUE
  280    CONTINUE
  290 CONTINUE
      RETURN
      END
      SUBROUTINE MAGIC(A,LDA,N)
C
C     ALGORITHMS FOR MAGIC SQUARES TAKEN FROM
C        MATHEMATICAL RECREATIONS AND ESSAYS, 12TH ED.,
C        BY W. W. ROUSE BALL AND H. S. M. COXETER
C
      DOUBLE PRECISION A(LDA,N),T
C
      IF (MOD(N,4) .EQ. 0) GO TO 100
      IF (MOD(N,2) .EQ. 0) M = N/2
      IF (MOD(N,2) .NE. 0) M = N
C
C     ODD ORDER OR UPPER CORNER OF EVEN ORDER
C
      DO 20 J = 1,M
         DO 10 I = 1,M
            A(I,J) = 0
   10    CONTINUE
   20 CONTINUE
      I = 1
      J = (M+1)/2
      MM = M*M
      DO 40 K = 1, MM
         A(I,J) = K
         I1 = I-1
         J1 = J+1
         IF(I1.LT.1) I1 = M
         IF(J1.GT.M) J1 = 1
         IF(IDINT(A(I1,J1)).EQ.0) GO TO 30
            I1 = I+1
            J1 = J
   30    I = I1
         J = J1
   40 CONTINUE
      IF (MOD(N,2) .NE. 0) RETURN
C
C     REST OF EVEN ORDER
C
      T = M*M
      DO 60 I = 1, M
         DO 50 J = 1, M
            IM = I+M
            JM = J+M
            A(I,JM) = A(I,J) + 2*T
            A(IM,J) = A(I,J) + 3*T
            A(IM,JM) = A(I,J) + T
   50    CONTINUE
   60 CONTINUE
      M1 = (M-1)/2
      IF (M1.EQ.0) RETURN
      DO 70 J = 1, M1
         CALL RSWAP(M,A(1,J),1,A(M+1,J),1)
   70 CONTINUE
      M1 = (M+1)/2
      M2 = M1 + M
      CALL RSWAP(1,A(M1,1),1,A(M2,1),1)
      CALL RSWAP(1,A(M1,M1),1,A(M2,M1),1)
      M1 = N+1-(M-3)/2
      IF(M1.GT.N) RETURN
      DO 80 J = M1, N
         CALL RSWAP(M,A(1,J),1,A(M+1,J),1)
   80 CONTINUE
      RETURN
C
C     DOUBLE EVEN ORDER
C
  100 K = 1
      DO 120 I = 1, N
         DO 110 J = 1, N
            A(I,J) = K
            IF (MOD(I,4)/2 .EQ. MOD(J,4)/2) A(I,J) = N*N+1 - K
            K = K+1
  110    CONTINUE
  120 CONTINUE
      RETURN
      END
      SUBROUTINE BASE(X,B,EPS,S,N)
      DOUBLE PRECISION X,B,EPS,S(1),T
C
C     STORE BASE B REPRESENTATION OF X IN S(1:N)
C
      INTEGER PLUS,MINUS,DOT,ZERO,COMMA
      DATA PLUS/41/,MINUS/42/,DOT/47/,ZERO/0/,COMMA/48/
      L = 1
      IF (X .GE. 0.0D0) S(L) = PLUS
      IF (X .LT. 0.0D0) S(L) = MINUS
      S(L+1) = ZERO
      S(L+2) = DOT
      X = DABS(X)
      IF (X .NE. 0.0D0) K = DLOG(X)/DLOG(B)
      IF (X .EQ. 0.0D0) K = 0
      IF (X .GT. 1.0D0) K = K + 1
      X = X/B**K
      IF (B*X .GE. B) K = K + 1
      IF (B*X .GE. B) X = X/B
      IF (EPS .NE. 0.0D0) M = -DLOG(EPS)/DLOG(B) + 4
      IF (EPS .EQ. 0.0D0) M = 54
      DO 10 L = 4, M
      X = B*X
      J = IDINT(X)
      S(L) = DFLOAT(J)
      X = X - S(L)
   10 CONTINUE
      S(M+1) = COMMA
      IF (K .GE. 0) S(M+2) = PLUS
      IF (K .LT. 0) S(M+2) = MINUS
      T = DABS(DFLOAT(K))
      N = M + 3
      IF (T .GE. B) N = N + IDINT(DLOG(T)/DLOG(B))
      L = N
   20 J = IDINT(DMOD(T,B))
      S(L) = DFLOAT(J)
      L = L - 1
      T = T/B
      IF (L .GE. M+3) GO TO 20
      RETURN
      END
      DOUBLE PRECISION FUNCTION URAND(IY)
      INTEGER IY
C
C      URAND IS A UNIFORM RANDOM NUMBER GENERATOR BASED  ON  THEORY  AND
C  SUGGESTIONS  GIVEN  IN  D.E. KNUTH (1969),  VOL  2.   THE INTEGER  IY
C  SHOULD BE INITIALIZED TO AN ARBITRARY INTEGER PRIOR TO THE FIRST CALL
C  TO URAND.  THE CALLING PROGRAM SHOULD  NOT  ALTER  THE  VALUE  OF  IY
C  BETWEEN  SUBSEQUENT CALLS TO URAND.  VALUES OF URAND WILL BE RETURNED
C  IN THE INTERVAL (0,1).
C
      INTEGER IA,IC,ITWO,M2,M,MIC
      DOUBLE PRECISION HALFM,S
      DOUBLE PRECISION DATAN,DSQRT
      DATA M2/0/,ITWO/2/
      IF (M2 .NE. 0) GO TO 20
C
C  IF FIRST ENTRY, COMPUTE MACHINE INTEGER WORD LENGTH
C
      M = 1
   10 M2 = M
      M = ITWO*M2
      IF (M .GT. M2) GO TO 10
      HALFM = M2
C
C  COMPUTE MULTIPLIER AND INCREMENT FOR LINEAR CONGRUENTIAL METHOD
C
      IA = 8*IDINT(HALFM*DATAN(1.D0)/8.D0) + 5
      IC = 2*IDINT(HALFM*(0.5D0-DSQRT(3.D0)/6.D0)) + 1
      MIC = (M2 - IC) + M2
C
C  S IS THE SCALE FACTOR FOR CONVERTING TO FLOATING POINT
C
      S = 0.5D0/HALFM
C
C  COMPUTE NEXT RANDOM NUMBER
C
   20 IY = IY*IA
C
C  THE FOLLOWING STATEMENT IS FOR COMPUTERS WHICH DO NOT ALLOW
C  INTEGER OVERFLOW ON ADDITION
C
      IF (IY .GT. MIC) IY = (IY - M2) - M2
C
      IY = IY + IC
C
C  THE FOLLOWING STATEMENT IS FOR COMPUTERS WHERE THE
C  WORD LENGTH FOR ADDITION IS GREATER THAN FOR MULTIPLICATION
C
      IF (IY/2 .GT. M2) IY = (IY - M2) - M2
C
C  THE FOLLOWING STATEMENT IS FOR COMPUTERS WHERE INTEGER
C  OVERFLOW AFFECTS THE SIGN BIT
C
      IF (IY .LT. 0) IY = (IY + M2) + M2
      URAND = DFLOAT(IY)*S
      RETURN
      END
      SUBROUTINE WMUL(AR,AI,BR,BI,CR,CI)
      DOUBLE PRECISION AR,AI,BR,BI,CR,CI,T,FLOP
C     C = A*B
      T = AR*BI + AI*BR
      IF (T .NE. 0.0D0) T = FLOP(T)
      CR = FLOP(AR*BR - AI*BI)
      CI = T
      RETURN
      END
      SUBROUTINE WDIV(AR,AI,BR,BI,CR,CI)
      DOUBLE PRECISION AR,AI,BR,BI,CR,CI
C     C = A/B
      DOUBLE PRECISION S,D,ARS,AIS,BRS,BIS,FLOP
      S = DABS(BR) + DABS(BI)
      IF (S .EQ. 0.0D0) CALL ERROR(27)
      IF (S .EQ. 0.0D0) RETURN
      ARS = AR/S
      AIS = AI/S
      BRS = BR/S
      BIS = BI/S
      D = BRS**2 + BIS**2
      CR = FLOP((ARS*BRS + AIS*BIS)/D)
      CI = (AIS*BRS - ARS*BIS)/D
      IF (CI .NE. 0.0D0) CI = FLOP(CI)
      RETURN
      END
      SUBROUTINE WSIGN(XR,XI,YR,YI,ZR,ZI)
      DOUBLE PRECISION XR,XI,YR,YI,ZR,ZI,PYTHAG,T
C     IF Y .NE. 0, Z = X*Y/ABS(Y)
C     IF Y .EQ. 0, Z = X
      T = PYTHAG(YR,YI)
      ZR = XR
      ZI = XI
      IF (T .NE. 0.0D0) CALL WMUL(YR/T,YI/T,ZR,ZI,ZR,ZI)
      RETURN
      END
      SUBROUTINE WSQRT(XR,XI,YR,YI)
      DOUBLE PRECISION XR,XI,YR,YI,S,TR,TI,PYTHAG,FLOP
C     Y = SQRT(X) WITH YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
C
      TR = XR
      TI = XI
      S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
      IF (TR .GE. 0.0D0) YR = FLOP(S)
      IF (TI .LT. 0.0D0) S = -S
      IF (TR .LE. 0.0D0) YI = FLOP(S)
      IF (TR .LT. 0.0D0) YR = FLOP(0.5D0*(TI/YI))
      IF (TR .GT. 0.0D0) YI = FLOP(0.5D0*(TI/YR))
      RETURN
      END
      SUBROUTINE WLOG(XR,XI,YR,YI)
      DOUBLE PRECISION XR,XI,YR,YI,T,R,PYTHAG
C     Y = LOG(X)
      R = PYTHAG(XR,XI)
      IF (R .EQ. 0.0D0) CALL ERROR(32)
      IF (R .EQ. 0.0D0) RETURN
      T = DATAN2(XI,XR)
      IF (XI.EQ.0.0D0 .AND. XR.LT.0.0D0) T = DABS(T)
      YR = DLOG(R)
      YI = T
      RETURN
      END
      SUBROUTINE WATAN(XR,XI,YR,YI)
C     Y = ATAN(X) = (I/2)*LOG((I+X)/(I-X))
      DOUBLE PRECISION XR,XI,YR,YI,TR,TI
      IF (XI .NE. 0.0D0) GO TO 10
         YR = DATAN2(XR,1.0D0)
         YI = 0.0D0
         RETURN
   10 IF (XR.NE.0.0D0 .OR. DABS(XI).NE.1.0D0) GO TO 20
         CALL ERROR(32)
         RETURN
   20 CALL WDIV(XR,1.0D0+XI,-XR,1.0D0-XI,TR,TI)
      CALL WLOG(TR,TI,TR,TI)
      YR = -TI/2.0D0
      YI = TR/2.0D0
      RETURN
      END
      DOUBLE PRECISION FUNCTION WNRM2(N,XR,XI,INCX)
      DOUBLE PRECISION XR(1),XI(1),PYTHAG,S
C     NORM2(X)
      S = 0.0D0
      IF (N .LE. 0) GO TO 20
      IX = 1
      DO 10 I = 1, N
         S = PYTHAG(S,XR(IX))
         S = PYTHAG(S,XI(IX))
         IX = IX + INCX
   10 CONTINUE
   20 WNRM2 = S
      RETURN
      END
      DOUBLE PRECISION FUNCTION WASUM(N,XR,XI,INCX)
      DOUBLE PRECISION XR(1),XI(1),S,FLOP
C     NORM1(X)
      S = 0.0D0
      IF (N .LE. 0) GO TO 20
      IX = 1
      DO 10 I = 1, N
         S = FLOP(S + DABS(XR(IX)) + DABS(XI(IX)))
         IX = IX + INCX
   10 CONTINUE
   20 WASUM = S
      RETURN
      END
      INTEGER FUNCTION IWAMAX(N,XR,XI,INCX)
      DOUBLE PRECISION XR(1),XI(1),S,P
C     INDEX OF NORMINF(X)
      K = 0
      IF (N .LE. 0) GO TO 20
      K = 1
      S = 0.0D0
      IX = 1
      DO 10 I = 1, N
         P = DABS(XR(IX)) + DABS(XI(IX))
         IF (P .GT. S) K = I
         IF (P .GT. S) S = P
         IX = IX + INCX
   10 CONTINUE
   20 IWAMAX = K
      RETURN
      END
      SUBROUTINE WRSCAL(N,S,XR,XI,INCX)
      DOUBLE PRECISION S,XR(1),XI(1),FLOP
      IF (N .LE. 0) RETURN
      IX = 1
      DO 10 I = 1, N
         XR(IX) = FLOP(S*XR(IX))
         IF (XI(IX) .NE. 0.0D0) XI(IX) = FLOP(S*XI(IX))
         IX = IX + INCX
   10 CONTINUE
      RETURN
      END
      SUBROUTINE WSCAL(N,SR,SI,XR,XI,INCX)
      DOUBLE PRECISION SR,SI,XR(1),XI(1)
      IF (N .LE. 0) RETURN
      IX = 1
      DO 10 I = 1, N
         CALL WMUL(SR,SI,XR(IX),XI(IX),XR(IX),XI(IX))
         IX = IX + INCX
   10 CONTINUE
      RETURN
      END
      SUBROUTINE WAXPY(N,SR,SI,XR,XI,INCX,YR,YI,INCY)
      DOUBLE PRECISION SR,SI,XR(1),XI(1),YR(1),YI(1),FLOP
      IF (N .LE. 0) RETURN
      IF (SR .EQ. 0.0D0 .AND. SI .EQ. 0.0D0) RETURN
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX + 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 10 I = 1, N
         YR(IY) = FLOP(YR(IY) + SR*XR(IX) - SI*XI(IX))
         YI(IY) = YI(IY) + SR*XI(IX) + SI*XR(IX)
         IF (YI(IY) .NE. 0.0D0) YI(IY) = FLOP(YI(IY))
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION WDOTUR(N,XR,XI,INCX,YR,YI,INCY)
      DOUBLE PRECISION XR(1),XI(1),YR(1),YI(1),S,FLOP
      S = 0.0D0
      IF (N .LE. 0) GO TO 20
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX + 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 10 I = 1, N
         S = FLOP(S + XR(IX)*YR(IY) - XI(IX)*YI(IY))
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
   20 WDOTUR = S
      RETURN
      END
      DOUBLE PRECISION FUNCTION WDOTUI(N,XR,XI,INCX,YR,YI,INCY)
      DOUBLE PRECISION XR(1),XI(1),YR(1),YI(1),S,FLOP
      S = 0.0D0
      IF (N .LE. 0) GO TO 20
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX + 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 10 I = 1, N
         S = S + XR(IX)*YI(IY) + XI(IX)*YR(IY)
         IF (S .NE. 0.0D0) S = FLOP(S)
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
   20 WDOTUI = S
      RETURN
      END
      DOUBLE PRECISION FUNCTION WDOTCR(N,XR,XI,INCX,YR,YI,INCY)
      DOUBLE PRECISION XR(1),XI(1),YR(1),YI(1),S,FLOP
      S = 0.0D0
      IF (N .LE. 0) GO TO 20
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX + 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 10 I = 1, N
         S = FLOP(S + XR(IX)*YR(IY) + XI(IX)*YI(IY))
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
   20 WDOTCR = S
      RETURN
      END
      DOUBLE PRECISION FUNCTION WDOTCI(N,XR,XI,INCX,YR,YI,INCY)
      DOUBLE PRECISION XR(1),XI(1),YR(1),YI(1),S,FLOP
      S = 0.0D0
      IF (N .LE. 0) GO TO 20
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX + 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 10 I = 1, N
         S = S + XR(IX)*YI(IY) - XI(IX)*YR(IY)
         IF (S .NE. 0.0D0) S = FLOP(S)
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
   20 WDOTCI = S
      RETURN
      END
      SUBROUTINE WCOPY(N,XR,XI,INCX,YR,YI,INCY)
      DOUBLE PRECISION XR(1),XI(1),YR(1),YI(1)
      IF (N .LE. 0) RETURN
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX + 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 10 I = 1, N
         YR(IY) = XR(IX)
         YI(IY) = XI(IX)
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
      RETURN
      END
      SUBROUTINE WSET(N,XR,XI,YR,YI,INCY)
      INTEGER N,INCY
      DOUBLE PRECISION XR,XI,YR(1),YI(1)
      IY = 1
      IF (N .LE. 0 ) RETURN
      DO 10 I = 1,N
         YR(IY) = XR
         YI(IY) = XI
         IY = IY + INCY
   10 CONTINUE
      RETURN
      END
      SUBROUTINE WSWAP(N,XR,XI,INCX,YR,YI,INCY)
      DOUBLE PRECISION XR(1),XI(1),YR(1),YI(1),T
      IF (N .LE. 0) RETURN
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX + 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 10 I = 1, N
         T = XR(IX)
         XR(IX) = YR(IY)
         YR(IY) = T
         T = XI(IX)
         XI(IX) = YI(IY)
         YI(IY) = T
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
      RETURN
      END
      SUBROUTINE RSET(N,DX,DY,INCY)
C
C     COPIES A SCALAR, X, TO A SCALAR, Y.
      DOUBLE PRECISION DX,DY(1)
C
      IF (N.LE.0) RETURN
      IY = 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DY(IY) = DX
        IY = IY + INCY
   10 CONTINUE
      RETURN
      END
      SUBROUTINE RSWAP(N,X,INCX,Y,INCY)
      DOUBLE PRECISION X(1),Y(1),T
      IF (N .LE. 0) RETURN
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX+1
      IF (INCY.LT.0) IY = (-N+1)*INCY+1
      DO 10 I = 1, N
         T = X(IX)
         X(IX) = Y(IY)
         Y(IY) = T
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
      RETURN
      END
      SUBROUTINE RROT(N,DX,INCX,DY,INCY,C,S)
C
C     APPLIES A PLANE ROTATION.
      DOUBLE PRECISION DX(1),DY(1),DTEMP,C,S,FLOP
      INTEGER I,INCX,INCY,IX,IY,N
C
      IF (N.LE.0) RETURN
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX + 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP = FLOP(C*DX(IX) + S*DY(IY))
        DY(IY) = FLOP(C*DY(IY) - S*DX(IX))
        DX(IX) = DTEMP
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
      END
      SUBROUTINE RROTG(DA,DB,C,S)
C
C     CONSTRUCT GIVENS PLANE ROTATION.
C
      DOUBLE PRECISION DA,DB,C,S,RHO,PYTHAG,FLOP,R,Z
C
      RHO = DB
      IF ( DABS(DA) .GT. DABS(DB) ) RHO = DA
      C = 1.0D0
      S = 0.0D0
      Z = 1.0D0
      R = FLOP(DSIGN(PYTHAG(DA,DB),RHO))
      IF (R .NE. 0.0D0) C = FLOP(DA/R)
      IF (R .NE. 0.0D0) S = FLOP(DB/R)
      IF ( DABS(DA) .GT. DABS(DB) ) Z = S
      IF ( DABS(DB) .GE. DABS(DA) .AND. C .NE. 0.0D0 ) Z = FLOP(1.0D0/C)
      DA = R
      DB = Z
      RETURN
      END
      LOGICAL FUNCTION EQID(X,Y)
C     CHECK FOR EQUALITY OF TWO NAMES
      INTEGER X(4),Y(4)
      EQID = .TRUE.
      DO 10 I = 1, 4
   10 EQID = EQID .AND. (X(I).EQ.Y(I))
      RETURN
      END
      SUBROUTINE PUTID(X,Y)
C     STORE A NAME
      INTEGER X(4),Y(4)
      DO 10 I = 1, 4
   10 X(I) = Y(I)
      RETURN
      END
      DOUBLE PRECISION FUNCTION ROUND(X)
      DOUBLE PRECISION X,Y,Z,E,H
      DATA H/1.0D9/
      Z = DABS(X)
      Y = Z + 1.0D0
      IF (Y .EQ. Z) GO TO 40
      Y = 0.0D0
      E = H
   10 IF (E .GE. Z) GO TO 20
         E = 2.0D0*E
         GO TO 10
   20 IF (E .LE. H) GO TO 30
         IF (E .LE. Z) Y = Y + E
         IF (E .LE. Z) Z = Z - E
         E = E/2.0D0
         GO TO 20
   30 Z = IDINT(Z + 0.5D0)
      Y = Y + Z
      IF (X .LT. 0.0D0) Y = -Y
      ROUND = Y
      RETURN
   40 ROUND = X
      RETURN
      END
      FUNCTION DFLOAT(I)
C
C   THIS IS THE AMIGA FUNCTION WHICH CONVERTS INTEGERS TO DOUBLE FLOATS
C
      IMPLICIT NONE
      DFLOAT = DBLE(I)
      RETURN
      END
