!
! gfortran matlab88.f90 -fno-range-check -O3 -o matlab
!

      PROGRAM BIGMAT
      CALL MATLAB(0)
      STOP
      END PROGRAM BIGMAT

      !module matlab_module
      !contains

!-----------------------------------------------------------------------
      SUBROUTINE CLAUSE
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,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/
      SAVE SEMI,EQUAL,EOL,BLANK
      SAVE COMMA,LESS,GREAT,NAME
      SAVE FOR,WHILE,IFF
      SAVE ELSE,ENND
      SAVE DO,THENN
      R = -FIN-10
      FIN = 0
      IF (DDT == 1) WRITE(WTE,100) PT,RSTK(PT),R
  100 FORMAT(1X,'CLAUSE',3I4)
      IF (R<1 .OR. R>6) GOTO 01
      GOTO (02,30,30,80,99,90),R
   01 R = RSTK(PT)
      GOTO (99,99,05,40,45,99,99,99,99,99,99,99,15,55,99,99,99),R
!
!     FOR
!
   02 CALL GETSYM
      IF (SYM /= NAME) CALL ERROR(34)
      IF (ERR > 0) RETURN
      PT = PT+2
      CALL PUTID(IDS(1,PT),SYN)
      CALL GETSYM
      IF (SYM /= EQUAL) CALL ERROR(34)
      IF (ERR > 0) RETURN
      CALL GETSYM
      RSTK(PT) = 3
!     *CALL* EXPR
      RETURN
   05 PSTK(PT-1) = 0
      PSTK(PT) = LPT(4) - 1
      IF (EQID(SYN,DO)) SYM = SEMI
      IF (SYM == COMMA) SYM = SEMI
      IF (SYM /= SEMI) CALL ERROR(34)
      IF (ERR > 0) RETURN
   10 J = PSTK(PT-1)
      LPT(4) = PSTK(PT)
      SYM = SEMI
      CHRA = BLANK
      J = J+1
      L = LSTK(TOP)
      M = MSTK(TOP)
      N = NSTK(TOP)
      LJ = L+(J-1)*M
      L2 = L + M*N
      IF (M /= -3) GOTO 12
      LJ = L+3
      L2 = LJ
      STKR(LJ) = STKR(L) + DFLOAT(J-1)*STKR(L+1)
      STKI(LJ) = 0.0
      IF (STKR(L+1)>0.0D0 .AND. STKR(LJ)>STKR(L+2)) GOTO 20
      IF (STKR(L+1)<0.0D0 .AND. STKR(LJ)<STKR(L+2)) GOTO 20
      M = 1
      N = J
   12 IF (J > N) GOTO 20
      IF (TOP+1 >= BOT) CALL ERROR(18)
      IF (ERR > 0) RETURN
      TOP = TOP+1
      LSTK(TOP) = L2
      MSTK(TOP) = M
      NSTK(TOP) = 1
      ERR = L2+M - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 0) RETURN
      CALL WCOPY(M,STKR(LJ),STKI(LJ),1,STKR(L2),STKI(L2),1)
      RHS = 0
      CALL STACKP(IDS(1,PT))
      IF (ERR > 0) RETURN
      PSTK(PT-1) = J
      PSTK(PT) = LPT(4)
      RSTK(PT) = 13
!     *CALL* PARSE
      RETURN
   15 GOTO 10
   20 MSTK(TOP) = 0
      NSTK(TOP) = 0
      RHS = 0
      CALL STACKP(IDS(1,PT))
      IF (ERR > 0) RETURN
      PT = PT-2
      GOTO 80
!
!     WHILE OR IF
!
   30 PT = PT+1
      CALL PUTID(IDS(1,PT),SYN)
      PSTK(PT) = LPT(4)-1
   35 LPT(4) = PSTK(PT)
      CHRA = BLANK
      CALL GETSYM
      RSTK(PT) = 4
!     *CALL* EXPR
      RETURN
   40 IF (SYM/=EQUAL .AND. SYM/=LESS .AND. SYM/=GREAT)&
          CALL ERROR(35)
      IF (ERR > 0) RETURN
      OP = SYM
      CALL GETSYM
      IF (SYM==EQUAL .OR. SYM==GREAT) OP = OP + SYM
      IF (OP > GREAT) CALL GETSYM
      PSTK(PT) = 256*PSTK(PT) + OP
      RSTK(PT) = 5
!     *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 == COMMA) SYM = SEMI
      IF (SYM /= SEMI) CALL ERROR(35)
      IF (ERR > 0) RETURN
      IF (OP==EQUAL         .AND. E1==E2) GOTO 50
      IF (OP==LESS          .AND. E1<E2) GOTO 50
      IF (OP==GREAT         .AND. E1>E2) GOTO 50
      IF (OP==(LESS+EQUAL)  .AND. E1<=E2) GOTO 50
      IF (OP==(GREAT+EQUAL) .AND. E1>=E2) GOTO 50
      IF (OP==(LESS+GREAT)  .AND. E1/=E2) GOTO 50
      PT = PT-1
      GOTO 80
   50 RSTK(PT) = 14
!     *CALL* PARSE
      RETURN
   55 IF (EQID(IDS(1,PT),WHILE)) GOTO 35
      PT = PT-1
      IF (EQID(SYN,ELSE)) GOTO 80
      RETURN
!
!     SEARCH FOR MATCHING END OR ELSE
   80 KOUNT = 0
      CALL GETSYM
   82 IF (SYM == EOL) RETURN
      IF (SYM /= NAME) GOTO 83
      IF (EQID(SYN,ENND) .AND. KOUNT==0) RETURN
      IF (EQID(SYN,ELSE) .AND. KOUNT==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
      GOTO 82
!
!     EXIT FROM LOOP
   90 IF (DDT == 1) WRITE(WTE,190) (RSTK(I),I=1,PT)
  190 FORMAT(1X,'EXIT  ',10I4)
      IF (RSTK(PT) == 14) PT = PT-1
      IF (PT <= PTZ) RETURN
      IF (RSTK(PT) == 14) PT = PT-1
      IF (PT-1 <= PTZ) RETURN
      IF (RSTK(PT) == 13) TOP = TOP-1
      IF (RSTK(PT) == 13) PT = PT-2
      GOTO 80
!
   99 CALL ERROR(22)
      IF (ERR > 0) RETURN
      RETURN
      END SUBROUTINE CLAUSE

!-----------------------------------------------------------------------
      SUBROUTINE COMAND(ID)
      INTEGER ID(4)
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,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/
      SAVE CMDL,A,D,E,Z,EOL,SEMI,COMMA,BLANK,NAME,DOT
!
!       CLEAR ELSE  END   EXIT
!       FOR   HELP  IF    LONG
!       RETUR SEMI
!       SHORT WHAT  WHILE
!       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/
!
      DATA LRECL/80/
      save LRECL
  101 FORMAT(80A1)
  102 FORMAT(1X,80A1)
!
      IF (DDT == 1) WRITE(WTE,100)
  100 FORMAT(1X,'COMAND')
      FUN = 0
      DO 10 K = 1, CMDL
        IF (EQID(ID,CMD(1,K))) GOTO 20
   10 CONTINUE
      FIN = 0
      RETURN
!
   20 IF (CHRA==COMMA .OR. CHRA==SEMI .OR. CHRA==EOL) GOTO 22
      IF (CHRA<=Z .OR. K==6) GOTO 22
      CALL ERROR(16)
      RETURN
!
   22 FIN = 1
      GOTO (25,36,38,40,30,80,34,52,44,55,50,65,32,60,70,46,48),K
!
!     CLEAR
   25 IF (CHRA>=A .AND. CHRA<=Z) GOTO 26
      BOT = LSIZE-3
      GOTO 98
   26 CALL GETSYM
      TOP = TOP+1
      MSTK(TOP) = 0
      NSTK(TOP) = 0
      RHS = 0
      CALL STACKP(SYN)
      IF (ERR > 0) RETURN
      FIN = 1
      GOTO 98
!
!     FOR, WHILE, IF, ELSE, END
   30 FIN = -11
      GOTO 99
   32 FIN = -12
      GOTO 99
   34 FIN = -13
      GOTO 99
   36 FIN = -14
      GOTO 99
   38 FIN = -15
      GOTO 99
!
!     EXIT
   40 IF (PT > PTZ) FIN = -16
      IF (PT > PTZ) GOTO 98
      K = IDINT(STKR(VSIZE-2))
      WRITE(WTE,140) K
      IF (WIO /= 0) WRITE(WIO,140) K
  140 FORMAT(/1X,'total flops ',I9//1X,'ADIOS'/)
      FUN = 99
      GOTO 98
!
!     RETURN
   44 K = LPT(1) - 7
      IF (K <= 0) FUN = 99
      IF (K <= 0) GOTO 98
      CALL FILES(-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)
      CHRA = BLANK
      SYM = COMMA
      GOTO 99
!
!     LALA
   46 WRITE(WTE,146)
  146 FORMAT(1X,'QUIT SINGING AND GET BACK TO WORK.')
      GOTO 98
!
!     FOO
   48 WRITE(WTE,148)
  148 FORMAT(1X,'YOUR PLACE OR MINE')
      GOTO 98
!
!     SHORT, LONG
   50 FMT = 1
      GOTO 54
   52 FMT = 2
   54 IF (CHRA==E .OR. CHRA==D) FMT = FMT+2
      IF (CHRA == Z) FMT = 5
      IF (CHRA==E .OR. CHRA==D .OR. CHRA==Z) CALL GETSYM
      GOTO 98
!
!     SEMI
   55 LCT(3) = 1 - LCT(3)
      GOTO 98
!
!     WHO
   60 WRITE(WTE,160)
      IF (WIO /= 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 /= 0) WRITE(WIO,161) L,VSIZE
  161 FORMAT(1X,'using ',I7,' out of ',I7,' elements.')
      GOTO 98
!
!     WHAT
   65 WRITE(WTE,165)
  165 FORMAT(1X,'The functions and commands are...')
      H(1) = 0
      CALL FUNS(H)
      CALL PRNTID(CMD,CMDL-2)
      GOTO 98
!
!     WHY
   70 K = IDINT(9.0D0*URAND(RAN(1))+1.0D0)
      GOTO (71,72,73,74,75,76,77,78,79),K
   71 WRITE(WTE,171)
  171 FORMAT(1X,'WHAT?')
      GOTO 98
   72 WRITE(WTE,172)
  172 FORMAT(1X,'R.T.F.M.')
      GOTO 98
   73 WRITE(WTE,173)
  173 FORMAT(1X,'HOW THE HELL SHOULD I KNOW?')
      GOTO 98
   74 WRITE(WTE,174)
  174 FORMAT(1X,'PETE MADE ME DO IT.')
      GOTO 98
   75 WRITE(WTE,175)
  175 FORMAT(1X,'INSUFFICIENT DATA TO ANSWER.')
      GOTO 98
   76 WRITE(WTE,176)
  176 FORMAT(1X,'IT FEELS GOOD.')
      GOTO 98
   77 WRITE(WTE,177)
  177 FORMAT(1X,'WHY NOT?')
      GOTO 98
   78 WRITE(WTE,178)
  178 FORMAT(1X,'/--ERROR'/1X,'STUPID QUESTION.')
      GOTO 98
   79 WRITE(WTE,179)
  179 FORMAT(1X,'SYSTEM ERROR, RETRY')
      GOTO 98
!
!     HELP
   80 IF (CHRA /= EOL) GOTO 81
      WRITE(WTE,180)
      IF (WIO /= 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 /= 0) WRITE(WIO,181)
  181 FORMAT(1X,'ANS   EDIT  FILE  FUN   MACRO')
      WRITE(WTE,182) (ALFA(I),I=J,ALFL)
      IF (WIO /= 0) WRITE(WIO,182) (ALFA(I),I=J,ALFL)
  182 FORMAT(1X,17(A1,1X)/)
      GOTO 98
!
   81 CALL GETSYM
      IF (SYM == NAME) GOTO 82
      IF (SYM == 0) SYM = DOT
      H(1) = ALFA(SYM+1)
      H(2) = ALFA(BLANK+1)
      H(3) = ALFA(BLANK+1)
      H(4) = ALFA(BLANK+1)
      GOTO 84
   82 DO 83 I = 1, 4
        CH = SYN(I)
        H(I) = ALFA(CH+1)
   83 CONTINUE

   84 IF(HIO /= 0) THEN
      READ(HIO,101,END=89) (BUF(I),I=1,LRECL)
!DC.. IF (EOF(HIO)/=0) GOTO 89
      DO 85 I = 1, 4
        IF (H(I) /= BUF(I)) GOTO 84
   85 CONTINUE
      WRITE(WTE,102)
      IF (WIO /= 0) WRITE(WIO,102)
   86 K = LRECL + 1
   87 K = K - 1
      IF (BUF(K) == ALFA(BLANK+1)) GOTO 87
      WRITE(WTE,102) (BUF(I),I=1,K)
      IF (WIO /= 0) WRITE(WIO,102) (BUF(I),I=1,K)
      READ(HIO,101) (BUF(I),I=1,LRECL)
      IF (BUF(1) == ALFA(BLANK+1)) GOTO 86
      CALL FILES(-HIO,BUF)
      GOTO 98
      ENDIF
!
   89 WRITE(WTE,189) (H(I),I=1,4)
  189 FORMAT(1X,'SORRY, NO HELP ON ',4A1)
      CALL FILES(-HIO,BUF)
      GOTO 98
!
   98 CALL GETSYM
   99 RETURN
      END SUBROUTINE COMAND

!-----------------------------------------------------------------------
      SUBROUTINE EDIT(BUF,N)
      INTEGER BUF(N)
!
!     CALLED AFTER INPUT OF A SINGLE BACKSLASH
!     BUF CONTAINS PREVIOUS INPUT LINE, ONE CHAR PER WORD
!     ENTER LOCAL EDITOR IF AVAILABLE
!     OTHERWISE JUST
      RETURN
      END SUBROUTINE EDIT
!-----------------------------------------------------------------------
      SUBROUTINE ERROR(N)
      INTEGER N
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
      COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
      COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ
      COMMON /ALFS/ ALFA,ALFB,ALFL,CASE
      COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
      COMMON /COM/ SYM,SYN,BUF,CHRA,FLP,FIN,FUN,LHS,RHS,RAN
      CHARACTER*80 BLH
      BLH(1:80)='        '
!
      K = LPT(2) - LPT(1)
      IF (K < 1) K = 1
      LUNIT = WTE
   98 CONTINUE
!     ASSUME CHAR(7) IS CTRL-G
      WRITE(LUNIT,'(1X,A,''/--ERROR'',A1)') BLH(1:K),ERRMSG,CHAR(7)

      GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,&
            23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40),N
!
    1 WRITE(LUNIT,101)
  101 FORMAT(1X,'IMPROPER MULTIPLE ASSIGNMENT')
      GOTO 99
    2 WRITE(LUNIT,102)
  102 FORMAT(1X,'IMPROPER FACTOR')
      GOTO 99
    3 WRITE(LUNIT,103)
  103 FORMAT(1X,'EXPECT RIGHT PARENTHESIS')
      GOTO 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)
      GOTO 99
    5 WRITE(LUNIT,105)
  105 FORMAT(1X,'COLUMN LENGTHS DO NOT MATCH')
      GOTO 99
    6 WRITE(LUNIT,106)
  106 FORMAT(1X,'ROW LENGTHS DO NOT MATCH')
      GOTO 99
    7 WRITE(LUNIT,107)
  107 FORMAT(1X,'TEXT TOO LONG')
      GOTO 99
    8 WRITE(LUNIT,108)
  108 FORMAT(1X,'INCOMPATIBLE FOR ADDITION')
      GOTO 99
    9 WRITE(LUNIT,109)
  109 FORMAT(1X,'INCOMPATIBLE FOR SUBTRACTION')
      GOTO 99
   10 WRITE(LUNIT,110)
  110 FORMAT(1X,'INCOMPATIBLE FOR MULTIPLICATION')
       GOTO 99
   11 WRITE(LUNIT,111)
  111 FORMAT(1X,'INCOMPATIBLE FOR RIGHT DIVISION')
      GOTO 99
   12 WRITE(LUNIT,112)
  112 FORMAT(1X,'INCOMPATIBLE FOR LEFT DIVISION')
      GOTO 99
   13 WRITE(LUNIT,113)
  113 FORMAT(1X,'IMPROPER ASSIGNMENT TO PERMANENT VARIABLE')
      GOTO 99
   14 WRITE(LUNIT,114)
  114 FORMAT(1X,'EYE-DENTITY UNDEFINED BY CONTEXT')
      GOTO 99
   15 WRITE(LUNIT,115)
  115 FORMAT(1X,'IMPROPER ASSIGNMENT TO SUBMATRIX')
      GOTO 99
   16 WRITE(LUNIT,116)
  116 FORMAT(1X,'IMPROPER COMMAND')
      GOTO 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.')
      GOTO 99
   18 WRITE(LUNIT,118)
  118 FORMAT(1X,'TOO MANY NAMES')
      GOTO 99
   19 WRITE(LUNIT,119)
  119 FORMAT(1X,'MATRIX IS SINGULAR TO WORKING PRECISION')
      GOTO 99
   20 WRITE(LUNIT,120)
  120 FORMAT(1X,'MATRIX MUST BE SQUARE')
      GOTO 99
   21 WRITE(LUNIT,121)
  121 FORMAT(1X,'SUBSCRIPT OUT OF RANGE')
      GOTO 99
   22 WRITE(LUNIT,122) (RSTK(I),I=1,PT)
  122 FORMAT(1X,'RECURSION DIFFICULTIES',10I4)
      GOTO 99
   23 WRITE(LUNIT,123)
  123 FORMAT(1X,'ONLY 1, 2 OR INF NORM OF MATRIX')
      GOTO 99
   24 WRITE(LUNIT,124)
  124 FORMAT(1X,'NO CONVERGENCE')
      GOTO 99
   25 WRITE(LUNIT,125)
  125 FORMAT(1X,'CAN NOT USE FUNCTION NAME AS VARIABLE')
      GOTO 99
   26 WRITE(LUNIT,126)
  126 FORMAT(1X,'TOO COMPLICATED (STACK OVERFLOW)')
      GOTO 99
   27 WRITE(LUNIT,127)
  127 FORMAT(1X,'DIVISION BY ZERO IS A NO-NO')
      GOTO 99
   28 WRITE(LUNIT,128)
  128 FORMAT(1X,'EMPTY MACRO')
      GOTO 99
   29 WRITE(LUNIT,129)
  129 FORMAT(1X,'NOT POSITIVE DEFINITE')
      GOTO 99
   30 WRITE(LUNIT,130)
  130 FORMAT(1X,'IMPROPER EXPONENT')
      GOTO 99
   31 WRITE(LUNIT,131)
  131 FORMAT(1X,'IMPROPER STRING')
      GOTO 99
   32 WRITE(LUNIT,132)
  132 FORMAT(1X,'SINGULARITY OF LOG OR ATAN')
      GOTO 99
   33 WRITE(LUNIT,133)
  133 FORMAT(1X,'TOO MANY COLONS')
      GOTO 99
   34 WRITE(LUNIT,134)
  134 FORMAT(1X,'IMPROPER FOR CLAUSE')
      GOTO 99
   35 WRITE(LUNIT,135)
  135 FORMAT(1X,'IMPROPER WHILE OR IF CLAUSE')
      GOTO 99
   36 WRITE(LUNIT,136)
  136 FORMAT(1X,'ARGUMENT OUT OF RANGE')
      GOTO 99
   37 WRITE(LUNIT,137)
  137 FORMAT(1X,'IMPROPER MACRO')
      GOTO 99
   38 WRITE(LUNIT,138)
  138 FORMAT(1X,'IMPROPER FILE NAME')
      GOTO 99
   39 WRITE(LUNIT,139)
  139 FORMAT(1X,'INCORRECT NUMBER OF ARGUMENTS')
      GOTO 99
   40 WRITE(LUNIT,140)
  140 FORMAT(1X,'EXPECT STATEMENT TERMINATOR')
      GOTO 99
!
   99 ERR = N
      IF (LUNIT==WIO .OR. WIO==0) RETURN
      LUNIT = WIO
      GOTO 98
      END SUBROUTINE ERROR
!-----------------------------------------------------------------------
      SUBROUTINE EXPR
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,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/
      SAVE COLON,BLANK,PLUS,MINUS,NAME,EYE
      IF (DDT == 1) WRITE(WTE,100) PT,RSTK(PT)
  100 FORMAT(1X,'EXPR  ',2I4)
      R = RSTK(PT)
      GOTO (01,01,01,01,01,05,25,99,99,01,01,99,99,99,99,99,99,01,01,&
             01),R
   01 IF (SYM == COLON) CALL PUTID(SYN,EYE)
      IF (SYM == COLON) SYM = NAME
      KOUNT = 1
   02 SIGN = PLUS
      IF (SYM == MINUS) SIGN = MINUS
      IF (SYM==PLUS .OR. SYM==MINUS) CALL GETSYM
      PT = PT+1
      IF (PT > PSIZE-1) CALL ERROR(26)
      IF (ERR > 0) RETURN
      PSTK(PT) = SIGN + 256*KOUNT
      RSTK(PT) = 6
!     *CALL* TERM
      RETURN
   05 SIGN = MOD(PSTK(PT),256)
      KOUNT = PSTK(PT)/256
      PT = PT-1
      IF (SIGN == MINUS) CALL STACK1(MINUS)
      IF (ERR > 0) RETURN
   10 IF (SYM==PLUS .OR. SYM==MINUS) GOTO 20
      GOTO 50
   20 IF (RSTK(PT) /= 10) GOTO 21
!     BLANK IS DELIMITER INSIDE ANGLE BRACKETS
      LS = LPT(3) - 2
      IF (LIN(LS) == BLANK) GOTO 50
   21 OP = SYM
      CALL GETSYM
      PT = PT+1
      PSTK(PT) = OP + 256*KOUNT
      RSTK(PT) = 7
!     *CALL* TERM
      RETURN
   25 OP = MOD(PSTK(PT),256)
      KOUNT = PSTK(PT)/256
      PT = PT-1
      CALL STACK2(OP)
      IF (ERR > 0) RETURN
      GOTO 10
   50 IF (SYM /= COLON) GOTO 60
      CALL GETSYM
      KOUNT = KOUNT+1
      GOTO 02
   60 IF (KOUNT > 3) CALL ERROR(33)
      IF (ERR > 0) RETURN
      RHS = KOUNT
      IF (KOUNT > 1) CALL STACK2(COLON)
      IF (ERR > 0) RETURN
      RETURN
   99 CALL ERROR(22)
      IF (ERR > 0) RETURN
      RETURN
      END SUBROUTINE EXPR
!-----------------------------------------------------------------------
      SUBROUTINE FACTOR
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,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/
      SAVE DSTAR,SEMI,EOL,BLANK
      SAVE STAR,COMMA,LPAREN,RPAREN
      SAVE LESS,GREAT,QUOTE,NUM,NAME,ALFL
      IF (DDT == 1) WRITE(WTE,100) PT,RSTK(PT),SYM
  100 FORMAT(1X,'FACTOR',3I4)
      R = RSTK(PT)
      GOTO (99,99,99,99,99,99,99,01,01,25,45,65,99,99,99,55,75,32,37),R
   01 IF (SYM==NUM .OR. SYM==QUOTE .OR.  SYM==LESS) GOTO 10
      IF (SYM == GREAT) GOTO 30
      EXCNT = 0
      IF (SYM == NAME) GOTO 40
      ID(1) = BLANK
      IF (SYM == LPAREN) GOTO 42
      CALL ERROR(2)
      IF (ERR > 0) RETURN
!
!     PUT SOMETHING ON THE STACK
   10 L = 1
      IF (TOP > 0) L = LSTK(TOP) + MSTK(TOP)*NSTK(TOP)
      IF (TOP+1 >= BOT) CALL ERROR(18)
      IF (ERR > 0) RETURN
      TOP = TOP+1
      LSTK(TOP) = L
      IF (SYM == QUOTE) GOTO 15
      IF (SYM == LESS) GOTO 20
!
!     SINGLE NUMBER, GETSYM STORED IT IN STKI
      MSTK(TOP) = 1
      NSTK(TOP) = 1
      STKR(L) = STKI(VSIZE)
      STKI(L) = 0.0D0
      CALL GETSYM
      GOTO 60
!
!     STRING
   15 N = 0
      LPT(4) = LPT(3)
      CALL GETCH
   16 IF (CHRA == QUOTE) GOTO 18
   17 LN = L+N
      IF (CHRA == EOL) CALL ERROR(31)
      IF (ERR > 0) RETURN
      STKR(LN) = DFLOAT(CHRA)
      STKI(LN) = 0.0D0
      N = N+1
      CALL GETCH
      GOTO 16
   18 CALL GETCH
      IF (CHRA == QUOTE) GOTO 17
      IF (N <= 0) CALL ERROR(31)
      IF (ERR > 0) RETURN
      MSTK(TOP) = 1
      NSTK(TOP) = N
      CALL GETSYM
      GOTO 60
!
!     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==SEMI .OR. SYM==GREAT .OR. SYM==EOL) GOTO 27
      IF (SYM == COMMA) CALL GETSYM
      PT = PT+1
      RSTK(PT) = 10
!     *CALL* EXPR
      RETURN
   25 PT = PT-1
      TOP = TOP - 1
      IF (MSTK(TOP) == 0) MSTK(TOP) = MSTK(TOP+1)
      IF (MSTK(TOP) /= MSTK(TOP+1)) CALL ERROR(5)
      IF (ERR > 0) RETURN
      NSTK(TOP) = NSTK(TOP) + NSTK(TOP+1)
      GOTO 22
   27 IF (SYM==SEMI .AND. CHRA==EOL) CALL GETSYM
      CALL STACK1(QUOTE)
      IF (ERR > 0) RETURN
      TOP = TOP - 1
      IF (MSTK(TOP) == 0) MSTK(TOP) = MSTK(TOP+1)
      IF (MSTK(TOP)/=MSTK(TOP+1) .AND. MSTK(TOP+1)>0) CALL ERROR(6)
      IF (ERR > 0) RETURN
      NSTK(TOP) = NSTK(TOP) + NSTK(TOP+1)
      IF (SYM == EOL) CALL GETLIN
      IF (SYM /= GREAT) GOTO 21
      CALL STACK1(QUOTE)
      IF (ERR > 0) RETURN
      CALL GETSYM
      GOTO 60
!
!     MACRO STRING
   30 CALL GETSYM
      IF (SYM==LESS .AND. CHRA==EOL) CALL ERROR(28)
      IF (ERR > 0) RETURN
      PT = PT+1
      RSTK(PT) = 18
!     *CALL* EXPR
      RETURN
   32 PT = PT-1
      IF (SYM/=LESS .AND. SYM/=EOL) CALL ERROR(37)
      IF (ERR > 0) RETURN
      IF (SYM == 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
!     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)<0 .OR. LIN(K)>=ALFL) CALL ERROR(37)
         IF (ERR > 0) RETURN
         IF (K<1024) K = K+1
         IF (K==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
      CHRA = BLANK
      CALL GETSYM
      PT = PT+1
      RSTK(PT) = 19
!     *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)
      CHRA = BLANK
      CALL GETSYM
      GOTO 60
!
!     FUNCTION OR MATRIX ELEMENT
   40 CALL PUTID(ID,SYN)
      CALL GETSYM
      IF (SYM == LPAREN) GOTO 42
      RHS = 0
      CALL FUNS(ID)
      IF (FIN /= 0) CALL ERROR(25)
      IF (ERR > 0) RETURN
      CALL STACKG(ID)
      IF (ERR > 0) RETURN
      IF (FIN == 7) GOTO 50
      IF (FIN == 0) CALL PUTID(IDS(1,PT+1),ID)
      IF (FIN == 0) CALL ERROR(4)
      IF (ERR > 0) RETURN
      GOTO 60
!
   42 CALL GETSYM
      EXCNT = EXCNT+1
      PT = PT+1
      PSTK(PT) = EXCNT
      CALL PUTID(IDS(1,PT),ID)
      RSTK(PT) = 11
!     *CALL* EXPR
      RETURN
   45 CALL PUTID(ID,IDS(1,PT))
      EXCNT = PSTK(PT)
      PT = PT-1
      IF (SYM == COMMA) GOTO 42
      IF (SYM /= RPAREN) CALL ERROR(3)
      IF (ERR > 0) RETURN
      IF (SYM == RPAREN) CALL GETSYM
      IF (ID(1) == BLANK) GOTO 60
      RHS = EXCNT
      CALL STACKG(ID)
      IF (ERR > 0) RETURN
      IF (FIN == 0) CALL FUNS(ID)
      IF (FIN == 0) CALL ERROR(4)
      IF (ERR > 0) RETURN
!
!     EVALUATE MATRIX FUNCTION
   50 PT = PT+1
      RSTK(PT) = 16
!     *CALL* MATFN
      RETURN
   55 PT = PT-1
      GOTO 60
!
!     CHECK FOR QUOTE (TRANSPOSE) AND ** (POWER)
   60 IF (SYM /= QUOTE) GOTO 62
         I = LPT(3) - 2
         IF (LIN(I) == BLANK) GOTO 90
         CALL STACK1(QUOTE)
         IF (ERR > 0) RETURN
         CALL GETSYM
   62 IF (SYM/=STAR .OR. CHRA/=STAR) GOTO 90
      CALL GETSYM
      CALL GETSYM
      PT = PT+1
      RSTK(PT) = 12
!     *CALL* FACTOR
      GOTO 01
   65 PT = PT-1
      CALL STACK2(DSTAR)
      IF (ERR > 0) RETURN
      IF (FUN /= 2) GOTO 90
!     MATRIX POWER, USE EIGENVECTORS
      PT = PT+1
      RSTK(PT) = 17
!     *CALL* MATFN
      RETURN
   75 PT = PT-1
   90 RETURN
   99 CALL ERROR(22)
      IF (ERR > 0) RETURN
      RETURN
      END SUBROUTINE FACTOR
!-----------------------------------------------------------------------
      SUBROUTINE FILES(LUNIT,INAME)
      INTEGER LUNIT
!
!     AMIGA SPECIFIC ROUTINE TO ALLOCATE FILES
!     LUNIT = LOGICAL UNIT NUMBER
!     NAME = FILE NAME, 1 CHARACTER PER WORD
!
      INTEGER INAME(256)
      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
!
!  Amiga dependent stuff to squeeze the NAME from one CHAR per word to one
!  per byte
!
      character*1024 NAME2
      integer*1 strip(4,256),strip2(32)
      character*32 NAME3
      equivalence (NAME2,strip),(NAME3,strip2)
      WRITE(NAME,'(256A4)')(INAME(I),I=1,256)
!
      FE=0
!
! ERROR CATCHER
      IF (LUNIT == 0) RETURN
!
! PRINTER
      !if (LUNIT == RTE) return
!
! TERMINAL I/O
      !if (LUNIT == WTE) return

      if (LUNIT == 5) return
      if (LUNIT == 6) return
!-----------------------------------------------------------------------
! HELP FILE
      if (LUNIT == 11) then
         OPEN(11,FILE='matlab88_help.txt',STATUS='OLD',ERR=14)
         write(WTE,'(/,1X,''HELP is available'')')
         return
      elseif (LUNIT == -11 .AND. HIO /= 0) then
         rewind (11,ERR=99)
         return
      elseif (LUNIT < 0) then
         close(unit=-LUNIT,ERR=99)
         return
      end if
!-----------------------------------------------------------------------
   10 continue
!
!  ALL OTHER FILES
!
      NAME2=NAME
      do 37 j=1,32
   37 strip2(j)=strip(1,j)
      OPEN(UNIT=LUNIT,FILE=NAME3,STATUS='UNKNOWN',ERR=98)
      RETURN
!-----------------------------------------------------------------------
! HELP FILE NOT FOUND
!
   14 CONTINUE
      WRITE(WTE,'(1x,''HELP IS NOT AVAILABLE'')')
      HIO = 0
      RETURN
!-----------------------------------------------------------------------
! GENERAL FILE OPEN FAILURE
!
   98 WRITE(WTE,'(1X,''OPEN FILE FAILED'')')
      FE=1

! IF THIS WAS A DIARY FILE (OUTPUT), SET ITS FILE HANDLE TO 0

      IF(LUNIT == 8) THEN
        WIO=0
!
! OTHERWISE, SET THE I/O TO TERMINAL I/O
!
      ELSE
        RIO=RTE
      ENDIF
      RETURN
!-----------------------------------------------------------------------
   99 CONTINUE
      RETURN
!-----------------------------------------------------------------------
      END SUBROUTINE FILES

      DOUBLE PRECISION FUNCTION FLOP(X)
      DOUBLE PRECISION X
!     SYSTEM DEPENDENT FUNCTION
!     COUNT AND POSSIBLY CHOP EACH FLOATING POINT OPERATION
!     FLP(1) IS FLOP COUNTER
!     FLP(2) IS NUMBER OF PLACES TO BE CHOPPED
!
      INTEGER SYM,SYN(4),BUF(256),CHRA,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
      COMMON /COM/ SYM,SYN,BUF,CHRA,FLP,FIN,FUN,LHS,RHS,RAN
!
      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,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'/
      save mas
!
      FLP(1) = FLP(1) + 1
      K = FLP(2)
      FLOP = X
      IF (K <= 0) RETURN
      FLOP = 0.0D0
      IF (K >= 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 FUNCTION FLOP
!-----------------------------------------------------------------------
      SUBROUTINE FORMZ(LUNIT,X,Y)
      DOUBLE PRECISION X,Y
!
!     SYSTEM DEPENDENT ROUTINE TO PRINT WITH Z FORMAT
!
      IF (Y /= 0.0D0) WRITE(LUNIT,10) X,Y
      IF (Y == 0.0D0) WRITE(LUNIT,10) X
   10 FORMAT(2Z18)
      RETURN
      END SUBROUTINE FORMZ
!-----------------------------------------------------------------------
      SUBROUTINE FUNS(ID)
      INTEGER ID(4)
!
!     SCAN FUNCTION LIST
!
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,FLP,FIN,FUN,LHS,RHS,RAN
      LOGICAL EQID
      INTEGER FUNL,FUNN(4,57),FUNP(57)
      DATA FUNL/57/
!
!    1  ABS   ATAN  BASE  CHAR
!    2  CHOL  CHOP  COND  CONJ
!    3  COS   DET   DIAG  DIAR
!    4  DISP  EIG   EPS   EXEC
!    5  EXP   EYE   FLOP  HESS
!    6  HILB  IMAG  INV   KRON
!    7  LINE  LOAD  LOG   LU
!    8  MAGIC NORM  ONES  ORTH
!    9  PINV  PLOT  POLY  PRINT
!    $  PROD  QR    RAND  RANK
!    1  RAT   RCOND REAL  ROOT
!    2  ROUND RREF  SAVE  SCHUR
!    3  SIN   SIZE  SQRT  SUM
!    4  SVD   TRIL  TRIU  USER
!    5  DEBUG
!
      DATA FUNN/&
        10,11,28,36, 10,29,10,23, 11,10,28,14, 12,17,10,27,&
        12,17,24,21, 12,17,24,25, 12,24,23,13, 12,24,23,19,&
        12,24,28,36, 13,14,29,36, 13,18,10,16, 13,18,10,27,&
        13,18,28,25, 14,18,16,36, 14,25,28,36, 14,33,14,12,&
        14,33,25,36, 14,34,14,36, 15,21,24,25, 17,14,28,28,&
        17,18,21,11, 18,22,10,16, 18,23,31,36, 20,27,24,23,&
        21,18,23,14, 21,24,10,13, 21,24,16,36, 21,30,36,36,&
        22,10,16,18, 23,24,27,22, 24,23,14,28, 24,27,29,17,&
        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,&
        27,10,29,36, 27,12,24,23, 27,14,10,21, 27,24,24,29,&
        27,24,30,23, 27,27,14,15, 28,10,31,14, 28,12,17,30,&
        28,18,23,36, 28,18,35,14, 28,26,27,29, 28,30,22,36,&
        28,31,13,36, 29,27,18,21, 29,27,18,30, 30,28,14,27,&
        13,14,11,30/
!
      DATA FUNP/&
        221,203,507,509, 106,609,303,225, 202,102,602,505,&
        506,211,000,501, 204,606,000,213, 105,224,101,611,&
        508,503,206,104, 601,304,608,402, 302,510,214,504,&
        604,401,607,305, 511,103,223,215, 222,107,502,212,&
        201,610,205,603, 301,614,615,605, 512/
      save funl, funn, funp
!
      IF (ID(1)==0) CALL PRNTID(FUNN,FUNL-1)
      IF (ID(1)==0) RETURN
!
      DO 10 K = 1, FUNL
         IF (EQID(ID,FUNN(1,K))) GOTO 20
   10 CONTINUE
      FIN = 0
      RETURN
!
   20 FIN = MOD(FUNP(K),100)
      FUN = FUNP(K)/100
      IF (RHS==0 .AND. FUNP(K)==606) FIN = 0
      IF (RHS==0 .AND. FUNP(K)==607) FIN = 0
      RETURN
      END SUBROUTINE FUNS

!-----------------------------------------------------------------------
      SUBROUTINE GETCH
!     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),CHRA,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,CHRA,FLP,FIN,FUN,LHS,RHS,RAN
      INTEGER EOL
      DATA EOL/99/
      save EOL
      L = LPT(4)
      CHRA = LIN(L)
      IF (CHRA /= EOL) LPT(4) = L + 1
      RETURN
      END SUBROUTINE GETCH

!-----------------------------------------------------------------------
      SUBROUTINE GETLIN
!     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),CHRA,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,CHRA,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/
      SAVE  EOL, DOT, BLANK, RETU, SLASH, BSLASH, LRECL
!
   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)
!DC.. IF (EOF(RIO)/=0) GOTO 50
  101 FORMAT(80A1)
      N = LRECL+1
   15 N = N-1
      IF (BUF(N) == ALFA(BLANK+1)) GOTO 15
      IF (MOD(LCT(4),2) == 1) WRITE(WTE,102) (BUF(J),J=1,N)
      IF (WIO /= 0) WRITE(WIO,102) (BUF(J),J=1,N)
  102 FORMAT(1X,80A1)
!
      DO 40 J = 1, N
         DO 20 K = 1, ALFL
           IF (BUF(J)==ALFA(K) .OR. BUF(J)==ALFB(K)) GOTO 30
   20    CONTINUE
         K = EOL+1
!         CALL XCHAR(BUF(J),K)  ! handle backspace
         IF (K > EOL) GOTO 10
         IF (K == EOL) GOTO 45
         IF (K == -1) L = L-1
         IF (K <= 0) GOTO 40
!
   30    K = K-1
         IF (K==SLASH .AND. BUF(J+1)==BUF(J)) GOTO 45
         IF (K==DOT .AND. BUF(J+1)==BUF(J)) GOTO 11
         IF (K==BSLASH .AND. N==1) GOTO 60
         LIN(L) = K
         IF (L<1024) L = L+1
         IF (L==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
!
   50 IF (RIO == RTE) GOTO 52
      CALL PUTID(LIN(L),RETU)
      L = L + 4
      GOTO 45
   52 CALL FILES(-RTE,BUF)
      LIN(L) = EOL
      RETURN
!
   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==1 .AND. K<36) BUF(I) = ALFB(K+1)
   61 CONTINUE
      CALL EDIT(BUF,N)
      N = N + 1
      GOTO 15
      END SUBROUTINE GETLIN

!-----------------------------------------------------------------------
      SUBROUTINE GETSYM
!     GET A SYMBOL
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,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/
      SAVE BLANK,Z,DOT,D,E,EOL,PLUS,MINUS,NAME,NUM,STAR,SLASH,BSLASH
   10 IF (CHRA /= BLANK) GOTO 20
      CALL GETCH
      GOTO 10
   20 LPT(2) = LPT(3)
      LPT(3) = LPT(4)
      IF (CHRA <= 9) GOTO 50
      IF (CHRA <= Z) GOTO 30
!
!     SPECIAL CHARACTER
      SS = SYM
      SYM = CHRA
      CALL GETCH
      IF (SYM /= DOT) GOTO 90
!
!     IS DOT PART OF NUMBER OR OPERATOR
      SYV = 0.0D0
      IF (CHRA <= 9) GOTO 55
      IF (CHRA==STAR.OR.CHRA==SLASH.OR.CHRA==BSLASH) GOTO 90
      IF (SS==STAR .OR. SS==SLASH .OR. SS==BSLASH) GOTO 90
      GOTO 55
!
!     NAME
   30 SYM = NAME
      SYN(1) = CHRA
      CHCNT = 1
   40 CALL GETCH
      CHCNT = CHCNT+1
      IF (CHRA > Z) GOTO 45
      IF (CHCNT <= 4) SYN(CHCNT) = CHRA
      GOTO 40
   45 IF (CHCNT > 4) GOTO 47
      DO 46 I = CHCNT, 4
   46 SYN(I) = BLANK
   47 CONTINUE
      GOTO 90
!
!     NUMBER
   50 CALL GETVAL(SYV)
      IF (CHRA /= DOT) GOTO 60
      CALL GETCH
   55 CHCNT = LPT(4)
      CALL GETVAL(S)
      CHCNT = LPT(4) - CHCNT
      IF (CHRA == EOL) CHCNT = CHCNT+1
      SYV = SYV + S/10.0D0**CHCNT
   60 IF (CHRA/=D .AND. CHRA/=E) GOTO 70
      CALL GETCH
      SIGN = CHRA
      IF (SIGN==MINUS .OR. SIGN==PLUS) CALL GETCH
      CALL GETVAL(S)
      IF (SIGN /= MINUS) SYV = SYV*10.0D0**S
      IF (SIGN == MINUS) SYV = SYV/10.0D0**S
   70 STKI(VSIZE) = FLOP(SYV)
      SYM = NUM
!
   90 IF (CHRA /= BLANK) GOTO 99
      CALL GETCH
      GOTO 90
   99 IF (DDT /= 1) RETURN
      IF (SYM>NAME .AND. SYM<ALFL) WRITE(WTE,197) ALFA(SYM+1)
      IF (SYM >= ALFL) WRITE(WTE,198)
      IF (SYM == NAME) CALL PRNTID(SYN,1)
      IF (SYM == NUM) WRITE(WTE,199) SYV
  197 FORMAT(1X,A1)
  198 FORMAT(1X,'EOL')
  199 FORMAT(1X,G8.2)
      RETURN
      END SUBROUTINE GETSYM

!-----------------------------------------------------------------------
      SUBROUTINE GETVAL(S)
      DOUBLE PRECISION S
!     FORM NUMERICAL VALUE
      INTEGER SYM,SYN(4),BUF(256),CHRA,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
      COMMON /COM/ SYM,SYN,BUF,CHRA,FLP,FIN,FUN,LHS,RHS,RAN
      S = 0.0D0
   10 IF (CHRA > 9) RETURN
      S = 10.0D0*S + CHRA
      CALL GETCH
      GOTO 10
      END SUBROUTINE GETVAL
!-----------------------------------------------------------------------

      SUBROUTINE MATFN1
!
!     EVALUATE FUNCTIONS INVOLVING GAUSSIAN ELIMINATION
!
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,FLP,FIN,FUN,LHS,RHS,RAN
      DOUBLE PRECISION DTR(2),DTI(2),SR,SI,RCOND,T,T0,T1,FLOP,EPS,WASUM
!
      IF (DDT == 1) WRITE(WTE,100) FIN
  100 FORMAT(1X,'MATFN1',I4)
!
      L = LSTK(TOP)
      M = MSTK(TOP)
      N = NSTK(TOP)
      IF (FIN == -1) GOTO 10
      IF (FIN == -2) GOTO 20
      GOTO (30,40,50,60,70,80,85),FIN
!
!     MATRIX RIGHT DIVISION, A/A2
   10 L2 = LSTK(TOP+1)
      M2 = MSTK(TOP+1)
      N2 = NSTK(TOP+1)
      IF (M2 /= N2) CALL ERROR(20)
      IF (ERR > 0) RETURN
      IF (M*N == 1) GOTO 16
      IF (N /= N2) CALL ERROR(11)
      IF (ERR > 0) RETURN
      L3 = L2 + M2*N2
      ERR = L3+N2 - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 0) RETURN
      CALL WGECO(STKR(L2),STKI(L2),M2,N2,BUF,RCOND,STKR(L3),STKI(L3))
      IF (RCOND == 0.0D0) CALL ERROR(19)
      IF (ERR > 0) RETURN
      T = FLOP(1.0D0 + RCOND)
      IF (T==1.0D0 .AND. FUN/=21) WRITE(WTE,11) RCOND
      IF (T==1.0D0 .AND. FUN/=21 .AND. WIO/=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==1.0D0 .AND. FUN==21) WRITE(WTE,12) RCOND
      IF (T==1.0D0 .AND. FUN==21 .AND. WIO/=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 /= 21) GOTO 99
!
!     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 == 18) WRITE(WTE,115) SR,SI,EPS,T
  115 FORMAT(1X,'SR,SI,EPS,T',1P4D13.4)
      IF (SI <= EPS*SR) CALL RSET(N*N,0.0D0,STKI(L),1)
      GOTO 99
!
   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)
      GOTO 30
!
!     MATRIX LEFT DIVISION A BACKSLASH A2
   20 L2 = LSTK(TOP+1)
      M2 = MSTK(TOP+1)
      N2 = NSTK(TOP+1)
      IF (M /= N) CALL ERROR(20)
      IF (ERR > 0) RETURN
      IF (M2*N2 == 1) GOTO 26
      L3 = L2 + M2*N2
      ERR = L3+N - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 0) RETURN
      CALL WGECO(STKR(L),STKI(L),M,N,BUF,RCOND,STKR(L3),STKI(L3))
      IF (RCOND == 0.0D0) CALL ERROR(19)
      IF (ERR > 0) RETURN
      T = FLOP(1.0D0 + RCOND)
      IF (T == 1.0D0) WRITE(WTE,11) RCOND
      IF (T==1.0D0 .AND. WIO/=0) WRITE(WIO,11) RCOND
      IF (M2 /= N) CALL ERROR(12)
      IF (ERR > 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)
      GOTO 99
   26 SR = STKR(L2)
      SI = STKI(L2)
      GOTO 30
!
!     INV
!
   30 IF (M /= N) CALL ERROR(20)
      IF (ERR > 0) RETURN
      IF (DDT == 17) GOTO 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 /= T1) GOTO 32
   31 CONTINUE
      GOTO 72
   32 L3 = L + N*N
      ERR = L3+N - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 0) RETURN
      CALL WGECO(STKR(L),STKI(L),M,N,BUF,RCOND,STKR(L3),STKI(L3))
      IF (RCOND == 0.0D0) CALL ERROR(19)
      IF (ERR > 0) RETURN
      T = FLOP(1.0D0 + RCOND)
      IF (T == 1.0D0) WRITE(WTE,11) RCOND
      IF (T==1.0D0 .AND. WIO/=0) WRITE(WIO,11) RCOND
      CALL WGEDI(STKR(L),STKI(L),M,N,BUF,DTR,DTI,STKR(L3),STKI(L3),1)
      IF (FIN < 0) CALL WSCAL(N*N,SR,SI,STKR(L),STKI(L),1)
      GOTO 99
!
!     DET
!
   40 IF (M /= N) CALL ERROR(20)
      IF (ERR > 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 == 0.0D0) GOTO 42
   41 CONTINUE
      STKR(L) = DTR(1)*10.D0**K
      STKI(L) = DTI(1)*10.D0**K
      MSTK(TOP) = 1
      NSTK(TOP) = 1
      GOTO 99
   42 IF (DTI(1) == 0.0D0) WRITE(WTE,43) DTR(1),K
      IF (DTI(1) /= 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
      GOTO 99
!
!     RCOND
!
   50 IF (M /= N) CALL ERROR(20)
      IF (ERR > 0) RETURN
      L3 = L + N*N
      ERR = L3+N - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 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 == 1) GOTO 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
      GOTO 99
!
!     LU
!
   60 IF (M /= N) CALL ERROR(20)
      IF (ERR > 0) RETURN
      CALL WGEFA(STKR(L),STKI(L),M,N,BUF,INFO)
      IF (LHS /= 2) GOTO 99
      NN = N*N
      IF (TOP+1 >= BOT) CALL ERROR(18)
      IF (ERR > 0) RETURN
      TOP = TOP+1
      LSTK(TOP) = L + NN
      MSTK(TOP) = N
      NSTK(TOP) = N
      ERR = L+NN+NN - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 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 <= K) STKR(LU) = STKR(LL)
          IF (I <= K) STKI(LU) = STKI(LL)
          IF (I > K) STKR(LU) = 0.0D0
          IF (I > K) STKI(LU) = 0.0D0
          IF (I < K) STKR(LL) = 0.0D0
          IF (I < K) STKI(LL) = 0.0D0
          IF (I == K) STKR(LL) = 1.0D0
          IF (I == K) STKI(LL) = 0.0D0
          IF (I > K) STKR(LL) = -STKR(LL)
          IF (I > K) STKI(LL) = -STKI(LL)
   61   CONTINUE
        I = BUF(K)
        IF (I == K) GOTO 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
      GOTO 99
!
!     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 < 0) CALL WSCAL(N*N,SR,SI,STKR(L),STKI(L),1)
      GOTO 99
!
!     CHOLESKY
   80 IF (M /= N) CALL ERROR(20)
      IF (ERR > 0) RETURN
      CALL WPOFA(STKR(L),STKI(L),M,N,ERR)
      IF (ERR /= 0) CALL ERROR(29)
      IF (ERR > 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
      GOTO 99
!
!     RREF
   85 IF (RHS < 2) GOTO 86
        TOP = TOP-1
        L = LSTK(TOP)
        IF (MSTK(TOP) /= M) CALL ERROR(5)
        IF (ERR > 0) RETURN
        N = N + NSTK(TOP)
   86 CALL RREF(STKR(L),STKI(L),M,M,N,STKR(VSIZE-4))
      NSTK(TOP) = N
      GOTO 99
!
   99 RETURN
      END SUBROUTINE MATFN1

!-----------------------------------------------------------------------
         SUBROUTINE MATFN2
!
!     EVALUATE ELEMENTARY FUNCTIONS AND FUNCTIONS INVOLVING
!     EIGENVALUES AND EIGENVECTORS
!
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,FLP,FIN,FUN,LHS,RHS,RAN
      DOUBLE PRECISION PYTHAG,ROUND,TR,TI,SR,SI,POWR,POWI,FLOP
      LOGICAL HERM,SCHUR,VECT,HESS
!
      IF (DDT == 1) WRITE(WTE,100) FIN
  100 FORMAT(1X,'MATFN2',I4)
!
!     FUNCTIONS/FIN
!     **   SIN  COS ATAN  EXP  SQRT LOG
!      0    1    2    3    4    5    6
!    EIG  SCHU HESS POLY ROOT
!     11   12   13   14   15
!    ABS  ROUN REAL IMAG CONJ
!     21   22   23   24   25
      IF (FIN /= 0) GOTO 05
         L = LSTK(TOP+1)
         POWR = STKR(L)
         POWI = STKI(L)
   05 L = LSTK(TOP)
      M = MSTK(TOP)
      N = NSTK(TOP)
      IF (FIN >= 11 .AND. FIN <= 13) GOTO 10
      IF (FIN == 14 .AND. (M==1 .OR. N==1)) GOTO 50
      IF (FIN == 14) GOTO 10
      IF (FIN == 15) GOTO 60
      IF (FIN > 20) GOTO 40
      IF (M == 1 .OR. N == 1) GOTO 40
!
!     EIGENVALUES AND VECTORS
   10 IF (M /= N) CALL ERROR(20)
      IF (ERR > 0) RETURN
      SCHUR = FIN == 12
      HESS = FIN == 13
      VECT = LHS==2 .OR. FIN<10
      NN = N*N
      L2 = L + NN
      LD = L2 + NN
      LE = LD + N
      LW = LE + N
      ERR = LW+N - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 0) RETURN
      CALL WCOPY(NN,STKR(L),STKI(L),1,STKR(L2),STKI(L2),1)
!
!     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)==STKR(LS) .AND. STKI(LL)==-STKI(LS)
         IF (.NOT. HERM) GOTO 30
   15 CONTINUE
!
!     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 > 0) CALL ERROR(24)
      IF (ERR > 0) RETURN
      IF (JOB /= 0)&
        CALL HTRIBK(N,N,STKR(L2),STKI(L2),STKR(LW),N,STKR(L),STKI(L))
      GOTO 31
!
!     NON-HERMITIAN EIGENVALUE PROBLEM
   30 CALL CORTH(N,N,1,N,STKR(L2),STKI(L2),STKR(LW),STKI(LW))
      IF (.NOT.VECT .AND. HESS) GOTO 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 > 0) CALL ERROR(24)
      IF (ERR > 0) RETURN
!
!     VECTORS
   31 IF (.NOT.VECT) GOTO 34
      IF (TOP+1 >= BOT) CALL ERROR(18)
      IF (ERR > 0) RETURN
      TOP = TOP+1
      LSTK(TOP) = L2
      MSTK(TOP) = N
      NSTK(TOP) = N
!
!     DIAGONAL OF VALUES OR CANONICAL FORMS
   34 IF (.NOT.VECT .AND. .NOT.SCHUR .AND. .NOT.HESS) GOTO 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 < 10) GOTO 42
      IF (VECT .OR. .NOT.(SCHUR.OR.HESS)) GOTO 99
      CALL WCOPY(NN,STKR(L2),STKI(L2),1,STKR(L),STKI(L),1)
      GOTO 99
!
!     VECTOR OF EIGENVALUES
   37 IF (FIN == 14) GOTO 52
      CALL WCOPY(N,STKR(LD),STKI(LD),1,STKR(L),STKI(L),1)
      NSTK(TOP) = 1
      GOTO 99
!
!     ELEMENTARY FUNCTIONS
!     FOR MATRICES.. X,D = EIG(A), FUN(A) = X*FUN(D)/X
   40 INC = 1
      N = M*N
      L2 = L
      GOTO 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 /= 0) GOTO 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 == 1) TR = DSIN(SR)*DCOSH(SI)
        IF (FIN == 1) TI = DCOS(SR)*DSINH(SI)
        IF (FIN == 2) TR = DCOS(SR)*DCOSH(SI)
        IF (FIN == 2) TI = (-DSIN(SR))*DSINH(SI)
        IF (FIN == 3) CALL WATAN(SR,SI,TR,TI)
        IF (FIN == 4) TR = DEXP(SR)*DCOS(SI)
        IF (FIN == 4) TI = DEXP(SR)*DSIN(SI)
        IF (FIN == 5) CALL WSQRT(SR,SI,TR,TI)
        IF (FIN == 6) CALL WLOG(SR,SI,TR,TI)
        IF (FIN == 21) TR = PYTHAG(SR,SI)
        IF (FIN == 22) TR = ROUND(SR)
        IF (FIN == 23) TR = SR
        IF (FIN == 24) TR = SI
        IF (FIN == 25) TR = SR
        IF (FIN == 25) TI = -SI
        IF (ERR > 0) RETURN
        STKR(LS) = FLOP(TR)
        STKI(LS) = 0.0D0
        IF (TI /= 0.0D0) STKI(LS) = FLOP(TI)
   46 CONTINUE
      IF (INC == 1) GOTO 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
!     SIGNAL MATFN1 TO DIVIDE BY EIGENVECTORS
      FUN = 21
      FIN = -1
      TOP = TOP-1
      GOTO 99
!
!     POLY
!     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)
!
!     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
      GOTO 99
!
!     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)) == 0.0D0) GOTO 61
      N = MAX0(M*N - K-1, 0)
      IF (N <= 0) GOTO 65
      L2 = L1+N+1
      LW = L2+N*N
      ERR = LW+N - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 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 > 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 > 0) CALL ERROR(24)
      IF (ERR > 0) RETURN
   65 MSTK(TOP) = N
      NSTK(TOP) = 1
      GOTO 99
   99 RETURN
      END SUBROUTINE MATFN2

!-----------------------------------------------------------------------
      SUBROUTINE MATFN3
!
!     EVALUATE FUNCTIONS INVOLVING SINGULAR VALUE DECOMPOSITION
!
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,FLP,FIN,FUN,LHS,RHS,RAN
      LOGICAL FRO,INF
      DOUBLE PRECISION P,S,T,TOL,EPS
      DOUBLE PRECISION WDOTCR,WDOTCI,PYTHAG,WNRM2,WASUM,FLOP
!
      IF (DDT == 1) WRITE(WTE,100) FIN
  100 FORMAT(1X,'MATFN3',I4)
!
      IF (FIN==1 .AND. RHS==2) TOP = TOP-1
      L = LSTK(TOP)
      M = MSTK(TOP)
      N = NSTK(TOP)
      MN = M*N
      GOTO (50,70,10,30,70), FIN
!
!     COND
!
   10 LD = L + M*N
      L1 = LD + MIN0(M+1,N)
      L2 = L1 + N
      ERR = L2+MIN0(M,N) - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 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 /= 0) CALL ERROR(24)
      IF (ERR > 0) RETURN
      S = STKR(LD)
      LD = LD + MIN0(M,N) - 1
      T = STKR(LD)
      IF (T == 0.0D0) GOTO 13
      STKR(L) = FLOP(S/T)
      STKI(L) = 0.0D0
      MSTK(TOP) = 1
      NSTK(TOP) = 1
      GOTO 99
   13 WRITE(WTE,14)
      IF (WIO /= 0) WRITE(WIO,14)
   14 FORMAT(1X,'CONDITION IS INFINITE')
      MSTK(TOP) = 0
      GOTO 99
!
!     NORM
!
   30 P = 2.0D0
      INF = .FALSE.
      IF (RHS /= 2) GOTO 31
      FRO = IDINT(STKR(L))==15 .AND. MN>1
      INF = IDINT(STKR(L))==18 .AND. MN>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 > 1 .AND. N > 1) GOTO 40
      IF (P == 1.0D0) GOTO 36
      IF (P == 2.0D0) GOTO 38
      I = IWAMAX(MN,STKR(L),STKI(L),1) + L - 1
      S = DABS(STKR(I)) + DABS(STKI(I))
      IF (INF .OR. S == 0.0D0) GOTO 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 /= 0.0D0) P = 1.0D0/P
      S = FLOP(S*T**P)
      GOTO 49
   36 S = WASUM(MN,STKR(L),STKI(L),1)
      GOTO 49
   38 S = WNRM2(MN,STKR(L),STKI(L),1)
      GOTO 49
!
!     MATRIX NORM
!
   40 IF (INF) GOTO 43
      IF (P == 1.0D0) GOTO 46
      IF (P /= 2.0D0) CALL ERROR(23)
      IF (ERR > 0) RETURN
      LD = L + M*N
      L1 = LD + MIN0(M+1,N)
      L2 = L1 + N
      ERR = L2+MIN0(M,N) - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 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 /= 0) CALL ERROR(24)
      IF (ERR > 0) RETURN
      S = STKR(LD)
      GOTO 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
      GOTO 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
      GOTO 49
   49 STKR(L) = S
      STKI(L) = 0.0D0
      MSTK(TOP) = 1
      NSTK(TOP) = 1
      GOTO 99
!
!     SVD
!
   50 IF (LHS /= 3) GOTO 52
      K = M
      IF (RHS == 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 > 0) CALL ERROR(17)
      IF (ERR > 0) RETURN
      JOB = 11
      IF (RHS == 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/=J) STKR(LL) = 0.0D0
        STKI(LL) = 0.0D0
        LS = LD+I-1
        IF (I==J) STKR(LL) = STKR(LS)
        LS = L1+I-1
        IF (ERR/=0 .AND. I==J-1) STKR(LL) = STKR(LS)
   51 CONTINUE
      IF (ERR /= 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 >= BOT) CALL ERROR(18)
      IF (ERR > 0) RETURN
      TOP = TOP+1
      LSTK(TOP) = L + M*K
      MSTK(TOP) = K
      NSTK(TOP) = N
      IF (TOP+1 >= BOT) CALL ERROR(18)
      IF (ERR > 0) RETURN
      TOP = TOP+1
      LSTK(TOP) = L + M*K + K*N
      MSTK(TOP) = N
      NSTK(TOP) = N
      GOTO 99
!
   52 LD = L + M*N
      L1 = LD + MIN0(M+1,N)
      L2 = L1 + N
      ERR = L2+MIN0(M,N) - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 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 /= 0) CALL ERROR(24)
      IF (ERR > 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
      GOTO 99
!
!     PINV AND RANK
!
   70 TOL = -1.0D0
      IF (RHS /= 2) GOTO 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 == 5) LD = L + M*N
      LV = LD + M*N
      L1 = LV + N*N
      IF (FIN == 5) L1 = LD + N
      L2 = L1 + N
      ERR = L2+MIN0(M,N) - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 0) RETURN
      IF (FIN == 2) JOB = 11
      IF (FIN == 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 /= 0) CALL ERROR(24)
      IF (ERR > 0) RETURN
      EPS = STKR(VSIZE-4)
      IF (TOL < 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 <= TOL) GOTO 73
        K = J
        LL = LV+(J-1)*N
        IF (FIN == 2) CALL WRSCAL(N,1.0D0/S,STKR(LL),STKI(LL),1)
   72 CONTINUE
   73 IF (FIN == 5) GOTO 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
      GOTO 99
   78 STKR(L) = DFLOAT(K)
      STKI(L) = 0.0D0
      MSTK(TOP) = 1
      NSTK(TOP) = 1
      GOTO 99
!
   99 RETURN
      END SUBROUTINE MATFN3

!-----------------------------------------------------------------------
      SUBROUTINE MATFN4
!
!     EVALUATE FUNCTIONS INVOLVING QR DECOMPOSITION (LEAST SQUARES)
!
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,FLP,FIN,FUN,LHS,RHS,RAN
      DOUBLE PRECISION T,TOL,EPS,FLOP
      INTEGER QUOTE
      DATA QUOTE/49/
      save quote
!
      IF (DDT == 1) WRITE(WTE,100) FIN
  100 FORMAT(1X,'MATFN4',I4)
!
      L = LSTK(TOP)
      M = MSTK(TOP)
      N = NSTK(TOP)
      IF (FIN == -1) GOTO 10
      IF (FIN == -2) GOTO 20
      GOTO 40
!
!     RECTANGULAR MATRIX RIGHT DIVISION, A/A2
   10 L2 = LSTK(TOP+1)
      M2 = MSTK(TOP+1)
      N2 = NSTK(TOP+1)
      TOP = TOP + 1
      IF (N>1 .AND. N/=N2) CALL ERROR(11)
      IF (ERR > 0) RETURN
      CALL STACK1(QUOTE)
      IF (ERR > 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 > 0) RETURN
      TOP = TOP - 1
      M = N2
      N = M2
      GOTO 20
!
!     RECTANGULAR MATRIX LEFT DIVISION A BACKSLASH A2
!
   20 L2 = LSTK(TOP+1)
      M2 = MSTK(TOP+1)
      N2 = NSTK(TOP+1)
      IF (M2*N2 > 1) GOTO 21
        M2 = M
        N2 = M
        ERR = L2+M*M - LSTK(BOT)
        IF (ERR > 0) CALL ERROR(17)
        IF (ERR > 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 /= M) CALL ERROR(12)
      IF (ERR > 0) RETURN
      L3 = L2 + MAX0(M,N)*N2
      L4 = L3 + N
      ERR = L4 + N - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 0) RETURN
      IF (M > N) GOTO 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 > TOL) K = J
   27 CONTINUE
      IF (K < MN) WRITE(WTE,28) K,TOL
      IF (K<MN .AND. WIO/=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) > 0) GOTO 35
        K = -BUF(J)
        BUF(J) = K
   33   CONTINUE
          IF (K == J) GOTO 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)
          GOTO 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 == -1) CALL STACK1(QUOTE)
      IF (ERR > 0) RETURN
      GOTO 99
!
!     QR
!
   40 MM = MAX0(M,N)
      LS = L + MM*MM
      IF (LHS==1 .AND. FIN==1) LS = L
      LE = LS + M*N
      L4 = LE + MM
      ERR = L4+MM - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 0) RETURN
      IF (LS/=L) CALL WCOPY(M*N,STKR(L),STKI(L),1,STKR(LS),STKI(LS),1)
      JOB = 1
      IF (LHS<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==1 .AND. FIN==1) GOTO 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 == 2) GOTO 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 >= BOT) CALL ERROR(18)
      IF (ERR > 0) RETURN
      TOP = TOP+1
      LSTK(TOP) = LS
      MSTK(TOP) = M
      NSTK(TOP) = N
      IF (LHS == 2) GOTO 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 >= BOT) CALL ERROR(18)
      IF (ERR > 0) RETURN
      TOP = TOP+1
      LSTK(TOP) = LE
      MSTK(TOP) = N
      NSTK(TOP) = N
      GOTO 99
!
   99 RETURN
      END SUBROUTINE MATFN4
!-----------------------------------------------------------------------
      SUBROUTINE MATFN5
!
!     FILE HANDLING AND OTHER I/O
!
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,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/
      SAVE EOL,BLANK,PLUS,MINUS,QUOTE,SEMI,LRAT,MRAT
!
      IF (DDT == 1) WRITE(WTE,100) FIN
  100 FORMAT(1X,'MATFN5',I4)
!     FUNCTIONS/FIN
!     EXEC SAVE LOAD PRIN DIAR DISP BASE LINE CHAR PLOT RAT  DEBU
!      1    2    3    4    5    6    7    8    9   10   11   12
      L = LSTK(TOP)
      M = MSTK(TOP)
      N = NSTK(TOP)
      IF (FIN > 5) GOTO 15
!
!     CONVERT FILE NAME
      MN = M*N
      FLAG = 3
      IF (SYM == SEMI) FLAG = 0
      IF (RHS < 2) GOTO 12
         FLAG = IDINT(STKR(L))
         TOP2 = TOP
         TOP = TOP-1
         L = LSTK(TOP)
         MN = MSTK(TOP)*NSTK(TOP)
   12 LUN = -1
      IF (MN==1 .AND. STKR(L)<10.0D0) LUN = IDINT(STKR(L))
      IF (LUN >= 0) GOTO 15
      DO 14 J = 1, 32
         LS = L+J-1
         IF (J <= MN) CH = IDINT(STKR(LS))
         IF (J > MN) CH = BLANK
         IF (CH<0 .OR. CH>=ALFL) CALL ERROR(38)
         IF (ERR > 0) RETURN
         IF (CASE == 0) BUF(J) = ALFA(CH+1)
         IF (CASE == 1) BUF(J) = ALFB(CH+1)
   14 CONTINUE
!
   15 GOTO (20,30,35,25,27,60,65,70,50,80,40,95),FIN
!
!     EXEC
   20 IF (LUN == 0) GOTO 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 == RTE) RIO = 12
      RIO = RIO + 1
      IF (LUN > 0) RIO = LUN
      IF (LUN < 0) CALL FILES(RIO,BUF)
      IF (FLAG >= 4) WRITE(WTE,22)
   22 FORMAT(1X,'PAUSE MODE. ENTER BLANK LINES.')
      SYM = EOL
      MSTK(TOP) = 0
      GOTO 99
!
!     EXEC(0)
   23 RIO = RTE
      ERR = 99
      GOTO 99
!
!     PRINT
   25 K = WTE
      WTE = LUN
      IF (LUN < 0) WTE = 7
      IF (LUN < 0) CALL FILES(WTE,BUF)
      L = LCT(2)
      LCT(2) = 9999
      IF (RHS > 1) CALL PRINT(SYN,TOP2)
      LCT(2) = L
      WTE = K
      MSTK(TOP) = 0
      GOTO 99
!
!     DIARY
   27 WIO = LUN
      IF (LUN < 0) WIO = 8
      IF (LUN < 0) CALL FILES(WIO,BUF)
      MSTK(TOP) = 0
      GOTO 99
!
!     SAVE
   30 IF (LUN < 0) LUNIT = 1
      IF (LUN < 0) CALL FILES(LUNIT,BUF)
      IF (LUN > 0) LUNIT = LUN
      K = LSIZE-4
      IF (K < BOT) K = LSIZE
      IF (RHS == 2) K = TOP2
      IF (RHS == 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) /= 0.0D0) IMG = 1
      IF(FE == 0)CALL SAVLOD(LUNIT,BUF,M,N,IMG,0,STKR(L),STKI(L))
      K = K-1
      IF (K >= BOT) GOTO 32
      CALL FILES(-LUNIT,BUF)
      MSTK(TOP) = 0
      GOTO 99
!
!     LOAD
   35 IF (LUN < 0) LUNIT = 2
      IF (LUN < 0) CALL FILES(LUNIT,BUF)
      IF (LUN > 0) LUNIT = LUN
   36 JOB = LSTK(BOT) - L
      IF(FE == 0)&
      CALL SAVLOD(LUNIT,ID,MSTK(TOP),NSTK(TOP),IMG,JOB,STKR(L),STKI(L))
      MN = MSTK(TOP)*NSTK(TOP)
      IF (MN == 0) GOTO 39
      IF (IMG == 0) CALL RSET(MN,0.0D0,STKI(L),1)
      DO 38 I = 1, 4
         J = 0
   37    J = J+1
         IF (ID(I)/=ALFA(J) .AND. J<=BLANK) GOTO 37
         ID(I) = J-1
   38 CONTINUE
      SYM = SEMI
      RHS = 0
      CALL STACKP(ID)
      TOP = TOP + 1
      GOTO 36
   39 CALL FILES(-LUNIT,BUF)
      MSTK(TOP) = 0
      GOTO 99
!
!     RAT
   40 IF (RHS == 2) GOTO 44
      MN = M*N
      L2 = L
      IF (LHS == 2) L2 = L + MN
      LW = L2 + MN
      ERR = LW + LRAT - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 0) RETURN
      IF (LHS == 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 == 1) STKR(L) = FLOP(S/T)
         L = L + 1
         L2 = L2 + 1
   42 CONTINUE
      GOTO 99
   44 MRAT = IDINT(STKR(L))
      LRAT = IDINT(STKR(L-1))
      TOP = TOP - 1
      MSTK(TOP) = 0
      GOTO 99
!
!     CHAR
   50 K = IABS(IDINT(STKR(L)))
      IF (M*N/=1 .OR. K>=ALFL) CALL ERROR(36)
      IF (ERR > 0) RETURN
      CH = ALFA(K+1)
      IF (STKR(L) < 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) >= 0.0D0) ALFA(K+1) = CH
      IF (STKR(L) < 0.0D0) ALFB(K+1) = CH
      MSTK(TOP) = 0
      GOTO 99
!
!     DISP
   60 WRITE(WTE,61)
      IF (WIO /= 0) WRITE(WIO,61)
   61 FORMAT(1X,80A1)
      IF (RHS == 2) GOTO 65
      MN = M*N
      TEXT = .TRUE.
      DO 62 I = 1, MN
        LS = L+I-1
        CH = IDINT(STKR(LS))
        TEXT = TEXT .AND. (CH>=0) .AND. (CH<ALFL)
        TEXT = TEXT .AND. (DFLOAT(CH)==STKR(LS))
   62 CONTINUE
      DO 64 I = 1, M
      DO 63 J = 1, N
        LS = L+I-1+(J-1)*M
        IF (STKR(LS) == 0.0D0) CH = BLANK
        IF (STKR(LS) > 0.0D0) CH = PLUS
        IF (STKR(LS) < 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 /= 0) WRITE(WIO,61) (BUF(J),J=1,N)
   64 CONTINUE
      MSTK(TOP) = 0
      GOTO 99
!
!     BASE
   65 IF (RHS /= 2) CALL ERROR(39)
      IF (STKR(L) <= 1.0D0) CALL ERROR(36)
      IF (ERR > 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 == 6) GOTO 60
      GOTO 99
!
!     LINES
   70 LCT(2) = IDINT(STKR(L))
      MSTK(TOP) = 0
      GOTO 99
!
!     PLOT
   80 IF (RHS >= 2) GOTO 82
      N = M*N
      DO 81 I = 1, N
         LL = L+I-1
         STKI(LL) = DFLOAT(I)
   81 CONTINUE
      CALL PLOT(WTE,STKI(L),STKR(L),N,T,0)
      IF (WIO /= 0) CALL PLOT(WIO,STKI(L),STKR(L),N,T,0)
      MSTK(TOP) = 0
      GOTO 99
   82 IF (RHS == 2) K = 0
      IF (RHS == 3) K = M*N
      IF (RHS > 3) K = RHS - 2
      TOP = TOP - (RHS - 1)
      N = MSTK(TOP)*NSTK(TOP)
      IF (MSTK(TOP+1)*NSTK(TOP+1) /= N) CALL ERROR(5)
      IF (ERR > 0) RETURN
      LX = LSTK(TOP)
      LY = LSTK(TOP+1)
      IF (RHS > 3) L = LSTK(TOP+2)
      CALL PLOT(WTE,STKR(LX),STKR(LY),N,STKR(L),K)
      IF (WIO /= 0) CALL PLOT(WIO,STKR(LX),STKR(LY),N,STKR(L),K)
      MSTK(TOP) = 0
      GOTO 99
!
!     DEBUG
   95 DDT = IDINT(STKR(L))
      WRITE(WTE,96) DDT
   96 FORMAT(1X,'DEBUG ',I4)
      MSTK(TOP) = 0
      GOTO 99
!
   99 RETURN
      END SUBROUTINE MATFN5
!-----------------------------------------------------------------------
      SUBROUTINE MATFN6
!
!     EVALUATE UTILITY FUNCTIONS
!
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,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/
      save semi,unifor,normal,seed
!
      IF (DDT == 1) WRITE(WTE,100) FIN
  100 FORMAT(1X,'MATFN6',I4)
!     FUNCTIONS/FIN
!     MAGI DIAG SUM  PROD USER EYE  RAND ONES CHOP SIZE KRON  TRIL TRIU
!       1    2    3    4    5    6    7    8    9   10  11-13  14   15
      L = LSTK(TOP)
      M = MSTK(TOP)
      N = NSTK(TOP)
      GOTO (75,80,65,67,70,90,90,90,60,77,50,50,50,80,80),FIN
!
!     KRONECKER PRODUCT
   50 IF (RHS /= 2) CALL ERROR(39)
      IF (ERR > 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 > 0) CALL ERROR(17)
      IF (ERR > 0) RETURN
!     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
!           GET J-TH COLUMN OF B
            CALL WCOPY(M,STKR(LJ),STKI(LJ),1,STKR(L),STKI(L),1)
!           ADDRESS OF A(IA,JA)
            LS = LA + IA-1 + (JA-1)*MA
            DO 51 I = 1, M
!             A(IA,JA) OP B(I,J)
              IF (FIN == 11) CALL WMUL(STKR(LS),STKI(LS),&
                 STKR(L),STKI(L),STKR(L),STKI(L))
              IF (FIN == 12) CALL WDIV(STKR(LS),STKI(LS),&
                 STKR(L),STKI(L),STKR(L),STKI(L))
              IF (FIN == 13) CALL WDIV(STKR(L),STKI(L),&
                 STKR(LS),STKI(LS),STKR(L),STKI(L))
              IF (ERR > 0) RETURN
              L = L + 1
   51       CONTINUE
   52     CONTINUE
   53   CONTINUE
   54 CONTINUE
      MSTK(TOP) = M*MA
      NSTK(TOP) = N*NA
      GOTO 99
!
!     CHOP
   60 EPS0 = 1.0D0
   61 EPS0 = EPS0/2.0D0
      T = FLOP(1.0D0 + EPS0)
      IF (T > 1.0D0) GOTO 61
      EPS0 = 2.0D0*EPS0
      FLP(2) = IDINT(STKR(L))
      IF (SYM /= 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 > 1.0D0) GOTO 63
      EPS = 2.0D0*EPS
      T = STKR(VSIZE-4)
      IF (T<EPS .OR. T==EPS0) STKR(VSIZE-4) = EPS
      MSTK(TOP) = 0
      GOTO 99
!
!     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
      GOTO 69
!
!     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
      GOTO 99
!
!     USER
   70 S = 0.0D0
      T = 0.0D0
      IF (RHS < 2) GOTO 72
      IF (RHS < 3) GOTO 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
      GOTO 99
!
!     MAGIC
   75 N = MAX0(IDINT(STKR(L)),0)
      IF (N == 2) N = 0
      IF (N > 0) CALL MAGIC(STKR(L),N,N)
      CALL RSET(N*N,0.0D0,STKI(L),1)
      MSTK(TOP) = N
      NSTK(TOP) = N
      GOTO 99
!
!     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 == 1) GOTO 99
      NSTK(TOP) = 1
      TOP = TOP + 1
      LSTK(TOP) = L+1
      MSTK(TOP) = 1
      NSTK(TOP) = 1
      GOTO 99
!
!     DIAG, TRIU, TRIL
   80 K = 0
      IF (RHS /= 2) GOTO 81
         K = IDINT(STKR(L))
         TOP = TOP-1
         L = LSTK(TOP)
         M = MSTK(TOP)
         N = NSTK(TOP)
   81 IF (FIN >= 14) GOTO 85
      IF (M == 1 .OR. N == 1) GOTO 83
      IF (K>=0) MN=MIN0(M,N-K)
      IF (K<0) MN=MIN0(M+K,N)
      MSTK(TOP) = MAX0(MN,0)
      NSTK(TOP) = 1
      IF (MN <= 0) GOTO 99
      DO 82 I = 1, MN
         IF (K>=0) LS = L+(I-1)+(I+K-1)*M
         IF (K<0) LS = L+(I-K-1)+(I-1)*M
         LL = L+I-1
         STKR(LL) = STKR(LS)
         STKI(LL) = STKI(LS)
   82 CONTINUE
      GOTO 99
   83 N = MAX0(M,N)+IABS(K)
      ERR = L+N*N - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 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>=0) LS = L+I-1
         IF (K<0) LS = L+J-1
         LL = L+I-1+(J-1)*N
         IF (J-I == K) SR = STKR(LS)
         IF (J-I == K) SI = STKI(LS)
         STKR(LL) = SR
         STKI(LL) = SI
   84 CONTINUE
      GOTO 99
!
!     TRIL, TRIU
   85 DO 87 J = 1, N
         LD = L + J - K - 1 + (J-1)*M
         IF (FIN == 14) LL = J - K - 1
         IF (FIN == 14) LS = LD - LL
         IF (FIN == 15) LL = M - J + K
         IF (FIN == 15) LS = LD + 1
         IF (LL > 0) CALL WSET(LL,0.0D0,0.0D0,STKR(LS),STKI(LS),1)
   87 CONTINUE
      GOTO 99
!
!     EYE, RAND, ONES
   90 IF (M>1 .OR. RHS==0) GOTO 94
      IF (RHS /= 2) GOTO 91
        NN = IDINT(STKR(L))
        TOP = TOP-1
        L = LSTK(TOP)
        N = NSTK(TOP)
   91 IF (FIN/=7 .OR. N<4) GOTO 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)) GOTO 97
      IF (EQID(ID,SEED)) GOTO 98
   93 IF (N > 1) GOTO 94
      M = MAX0(IDINT(STKR(L)),0)
      IF (RHS == 2) N = MAX0(NN,0)
      IF (RHS /= 2) N = M
      ERR = L+M*N - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 0) RETURN
      MSTK(TOP) = M
      NSTK(TOP) = N
      IF (M*N == 0) GOTO 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==J .OR. FIN==8) STKR(LL) = 1.0D0
        IF (FIN==7 .AND. RAN(2)==0) STKR(LL) = FLOP(URAND(RAN(1)))
        IF (FIN/=7 .OR. RAN(2)==0) GOTO 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 > 1.0D0) GOTO 95
        STKR(LL) = FLOP(SR*DSQRT((-(2.0D0*DLOG(T)))/T))
   96 CONTINUE
      GOTO 99
!
!     SWITCH UNIFORM AND NORMAL
   97 RAN(2) = ID(1) - UNIFOR(1)
      MSTK(TOP) = 0
      GOTO 99
!
!     SEED
   98 IF (RHS == 2) RAN(1) = NN
      STKR(L) = RAN(1)
      MSTK(TOP) = 1
      IF (RHS == 2) MSTK(TOP) = 0
      NSTK(TOP) = 1
      GOTO 99
!
   99 RETURN
      END SUBROUTINE MATFN6
!-----------------------------------------------------------------------
      SUBROUTINE MATLAB(INIT)
!     INIT = 0 FOR ORDINARY FIRST ENTRY
!          = POSITIVE FOR SUBSEQUENT ENTRIES
!          = NEGATIVE FOR SILENT INITIALIZATION (SEE MATZ)
!
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,FLP,FIN,FUN,LHS,RHS,RAN
!
      DOUBLE PRECISION S,T
      INTEGER EPS(4),FLOPS(4),EYE(4),RAND(4)
!
!     CHARACTER SET
!            0       10       20       30       40       50
!
!     0      0        A        K        U   COLON  :  LESS   <
!     1      1        B        L        V   PLUS   +  GREAT  >
!     2      2        C        M        W   MINUS  -
!     3      3        D        N        X   STAR   *
!     4      4        E        O        Y   SLASH  /
!     5      5        F        P        Z   BSLASH \
!     6      6        G        Q  BLANK     EQUAL  =
!     7      7        H        R  LPAREN (  DOT    .
!     8      8        I        S  RPAREN )  COMMA  ,
!     9      9        J        T  SEMI   ;  QUOTE  '
!-----------------------------------------------------------------------
      CHARACTER SETA*52,SETB*52
      DATA SETA/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ ();:+-*/\=.,''<>'/
!     ALTERNATE CHARACTER SET
      DATA SETB/'0123456789abcdefghijklmnopqrstuvwxyz ();|+-*/$=.,"[]'/
      SAVE SETB, SETA
!
!-----------------------------------------------------------------------
      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',&          !' -JW : just to fix the syntax highlighting...
          1H<,1H>/
!     ALTERNATE CHARACTER SET
      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",&          !" -JW : just to fix the syntax highlighting...
          1H[,1H]/
!
      SAVE ALPHB, ALPHA
!-----------------------------------------------------------------------
      DATA EPS/14,25,28,36/,FLOPS/15,21,24,25/
      DATA EYE/14,34,14,36/,RAND/27,10,23,13/
      SAVE EPS, EYE, FLOPS, RAND
!-----------------------------------------------------------------------
      IF (INIT > 0) GOTO 90
!
!     RTE = UNIT NUMBER FOR TERMINAL INPUT
      RTE = 5
      CALL FILES(RTE,BUF)
      RIO = RTE
!
!     WTE = UNIT NUMBER FOR TERMINAL OUTPUT
      WTE = 6
      CALL FILES(WTE,BUF)
      WIO = 0
!
      IF (INIT >= 0) WRITE(WTE,100)
  100 FORMAT(//1X,'     < M A T L A B >',/,1X,'   Version of 05/25/82')
!
!     HIO = UNIT NUMBER FOR HELP FILE
      HIO = 11
      CALL FILES(HIO,BUF)
!
!     RANDOM NUMBER SEED
      RAN(1) = 0
!
!     INITIAL LINE LIMIT
      LCT(2) = 25
!
      ALFL = 52
      CASE = 0
!     CASE = 1 for file names in lower case
      DO 20 I = 1, ALFL
         ALFA(I) = ALPHA(I)
         ALFB(I) = ALPHB(I)
!	 READ(SETA(I:I),'(A1)')I_ALFA ! convert character to hollerith
!	 READ(SETB(I:I),'(A1)')I_ALFB ! convert character to hollerith
   20 CONTINUE
!
      VSIZE = 50505
      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 > 1.0D0) GOTO 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 < 0) RETURN
!
   90 CALL PARSE
      IF (FUN == 1) CALL MATFN1
      IF (FUN == 2) CALL MATFN2
      IF (FUN == 3) CALL MATFN3
      IF (FUN == 4) CALL MATFN4
      IF (FUN == 5) CALL MATFN5
      IF (FUN == 6) CALL MATFN6
      IF (FUN == 21) CALL MATFN1
      IF (FUN /= 99) GOTO 90
      RETURN
      END SUBROUTINE MATLAB
!-----------------------------------------------------------------------

      SUBROUTINE PARSE
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,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/
      save BLANK,SEMI,EQUAL,EOL,COMMA,COLON
      save LPAREN,RPAREN,LESS,GREAT,NAME,ALFL
      save ANS,ENND,ELSE
!
   01 R = 0
      IF (ERR > 0) PTZ = 0
      IF (ERR<=0 .AND. PT>PTZ) R = RSTK(PT)
      IF (DDT == 1) WRITE(WTE,100) PT,R,PTZ,ERR
  100 FORMAT(1X,'PARSE ',4I4)
      IF (R==15) GOTO 93
      IF (R==16 .OR. R==17) GOTO 94
      SYM = EOL
      TOP = 0
      IF (RIO /= RTE) CALL FILES(-RIO,BUF)
      RIO = RTE
      LCT(3) = 0
      LCT(4) = 2
      LPT(1) = 1
   10 IF (SYM==EOL .AND. MOD(LCT(4)/2,2)==1) CALL PROMPT(LCT(4)/4)
      IF (SYM == EOL) CALL GETLIN
      ERR = 0
      PT = PTZ
   15 EXCNT = 0
      IF (DDT == 1) WRITE(WTE,115) PT,TOP
  115 FORMAT(1X,'STATE ',2I4)
      LHS = 1
      CALL PUTID(ID,ANS)
      CALL GETSYM
      IF (SYM==COLON .AND. CHRA==EOL) DDT = 1-DDT
      IF (SYM == COLON) CALL GETSYM
      IF (SYM==SEMI .OR. SYM==COMMA .OR. SYM==EOL) GOTO 80
      IF (SYM == NAME) GOTO 20
      IF (SYM == LESS) GOTO 40
      IF (SYM == GREAT) GOTO 45
      GOTO 50
!
!     LHS BEGINS WITH NAME
   20 CALL COMAND(SYN)
      IF (ERR > 0) GOTO 01
      IF (FUN == 99) GOTO 95
      IF (FIN == -15) GOTO 80
      IF (FIN < 0) GOTO 91
      IF (FIN > 0) GOTO 70
!     IF NAME IS A FUNCTION, MUST BE RHS
      RHS = 0
      CALL FUNS(SYN)
      IF (FIN /= 0) GOTO 50
!     PEEK ONE CHARACTER AHEAD
      IF (CHRA==SEMI .OR. CHRA==COMMA .OR. CHRA==EOL)&
            CALL PUTID(ID,SYN)
      IF (CHRA == EQUAL) GOTO 25
      IF (CHRA == LPAREN) GOTO 30
      GOTO 50
!
!     LHS IS SIMPLE VARIABLE
   25 CALL PUTID(ID,SYN)
      CALL GETSYM
      CALL GETSYM
      GOTO 50
!
!     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
!     *CALL* EXPR
      GOTO 92
   35 CALL PUTID(ID,IDS(1,PT))
      EXCNT = PSTK(PT)
      PT = PT-1
      IF (SYM == COMMA) GOTO 32
      IF (SYM /= RPAREN) CALL ERROR(3)
      IF (ERR > 0) GOTO 01
      IF (ERR > 0) RETURN
      IF (SYM == RPAREN) CALL GETSYM
      IF (SYM == EQUAL) GOTO 50
!     LHS IS REALLY RHS, FORGET SCAN JUST DONE
      TOP = TOP - EXCNT
      LPT(4) = LPT(5)
      CHRA = LPAREN
      SYM = NAME
      CALL PUTID(SYN,ID)
      CALL PUTID(ID,ANS)
      EXCNT = 0
      GOTO 50
!
!     MULTIPLE LHS
   40 LPT(5) = LPT(4)
      PTS = PT
      CALL GETSYM
   41 IF (SYM /= NAME) GOTO 43
      CALL PUTID(ID,SYN)
      CALL GETSYM
      IF (SYM == GREAT) GOTO 42
      IF (SYM == COMMA) CALL GETSYM
      PT = PT+1
      LHS = LHS+1
      PSTK(PT) = 0
      CALL PUTID(IDS(1,PT),ID)
      GOTO 41
   42 CALL GETSYM
      IF (SYM == EQUAL) GOTO 50
   43 LPT(4) = LPT(5)
      PT = PTS
      LHS = 1
      SYM = LESS
      CHRA = LPT(4)-1
      CHRA = LIN(CHRA)
      CALL PUTID(ID,ANS)
      GOTO 50
!
!     MACRO STRING
   45 CALL GETSYM
      IF (DDT == 1) WRITE(WTE,145) PT,TOP
  145 FORMAT(1X,'MACRO ',2I4)
      IF (SYM==LESS .AND. CHRA==EOL) CALL ERROR(28)
      IF (ERR > 0) GOTO 01
      PT = PT+1
      RSTK(PT) = 20
!     *CALL* EXPR
      GOTO 92
   46 PT = PT-1
      IF (SYM/=LESS .AND. SYM/=EOL) CALL ERROR(37)
      IF (ERR > 0) GOTO 01
      IF (SYM == 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
!     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)<0 .OR. LIN(K)>=ALFL) CALL ERROR(37)
         IF (ERR > 0) RETURN
         IF (K<1024) K = K+1
         IF (K==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
      CHRA = BLANK
      PT = PT+1
      PSTK(PT) = LPT(1)
      RSTK(PT) = 21
!     *CALL* PARSE
      GOTO 15
   49 PT = PT-1
      IF (DDT == 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)
      CHRA = BLANK
      CALL GETSYM
      GOTO 80
!
!     LHS FINISHED, START RHS
   50 IF (SYM == EQUAL) CALL GETSYM
      PT = PT+1
      CALL PUTID(IDS(1,PT),ID)
      PSTK(PT) = EXCNT
      RSTK(PT) = 2
!     *CALL* EXPR
      GOTO 92
   55 IF (SYM==SEMI .OR. SYM==COMMA .OR. SYM==EOL) GOTO 60
      IF (SYM==NAME .AND. EQID(SYN,ELSE)) GOTO 60
      IF (SYM==NAME .AND. EQID(SYN,ENND)) GOTO 60
      CALL ERROR(40)
      IF (ERR > 0) GOTO 01
!
!     STORE RESULTS
   60 RHS = PSTK(PT)
      CALL STACKP(IDS(1,PT))
      IF (ERR > 0) GOTO 01
      PT = PT-1
      LHS = LHS-1
      IF (LHS > 0) GOTO 60
      GOTO 70
!
!     UPDATE AND POSSIBLY PRINT OPERATION COUNTS
   70 K = FLP(1)
      IF (K /= 0) STKR(VSIZE-3) = DFLOAT(K)
      STKR(VSIZE-2) = STKR(VSIZE-2) + DFLOAT(K)
      FLP(1) = 0
      IF (.NOT.(CHRA==COMMA .OR. (SYM==COMMA .AND. CHRA==EOL)))&
             GOTO 80
      CALL GETSYM
      I5 = 10**5
      LUNIT = WTE
   71 IF (K == 0) WRITE(LUNIT,171)
  171 FORMAT(/1X,'   no flops')
      IF (K == 1) WRITE(LUNIT,172)
  172 FORMAT(/1X,'    1 flop')
      IF (1<K .AND. K<100000) WRITE(LUNIT,173) K
  173 FORMAT(/1X,I5,' flops')
      IF (100000 <= K) WRITE(LUNIT,174) K
  174 FORMAT(/1X,I9,' flops')
      IF (LUNIT==WIO .OR. WIO==0) GOTO 80
      LUNIT = WIO
      GOTO 71
!
!     FINISH STATEMENT
   80 FIN = 0
      P = 0
      R = 0
      IF (PT > 0) P = PSTK(PT)
      IF (PT > 0) R = RSTK(PT)
      IF (DDT == 1) WRITE(WTE,180) PT,PTZ,P,R,LPT(1)
  180 FORMAT(1X,'FINISH',5I4)
      IF (SYM==COMMA .OR. SYM==SEMI) GOTO 15
      IF (R==21 .AND. P==LPT(1)) GOTO 49
      IF (PT > PTZ) GOTO 91
      GOTO 10
!
!     SIMULATE RECURSION
   91 CALL CLAUSE
      IF (ERR > 0) GOTO 01
      IF (PT <= PTZ) GOTO 15
      R = RSTK(PT)
      IF (R == 21) GOTO 49
      GOTO (99,99,92,92,92,99,99,99,99,99,99,99,15,15,99,99,99,99,99),R
!
   92 CALL EXPR
      IF (ERR > 0) GOTO 01
      R = RSTK(PT)
      GOTO (35,55,91,91,91,93,93,99,99,94,94,99,99,99,99,99,99,94,94,&
             46),R
!
   93 CALL TERM
      IF (ERR > 0) GOTO 01
      R = RSTK(PT)
      GOTO (99,99,99,99,99,92,92,94,94,99,99,99,99,99,95,99,99,99,99),R
!
   94 CALL FACTOR
      IF (ERR > 0) GOTO 01
      R = RSTK(PT)
      GOTO (99,99,99,99,99,99,99,93,93,92,92,94,99,99,99,95,95,92,92),R
!
!     CALL MATFNS BY RETURNING TO MATLAB
   95 IF (FIN>0 .AND. MSTK(TOP)<0) CALL ERROR(14)
      IF (ERR > 0) GOTO 01
      RETURN
!
   99 CALL ERROR(22)
      GOTO 01
      END SUBROUTINE PARSE

!-----------------------------------------------------------------------
      SUBROUTINE PLOT(LUNIT,X,Y,N,P,K)
      DOUBLE PRECISION X(N),Y(N),P(1)
      CHARACTER BUF*79
!
!     PLOT X VS. Y ON LUNIT
!     IF K IS NONZERO, THEN P(1),...,P(K) ARE EXTRA PARAMETERS
!     BUF IS WORK SPACE
!
      DOUBLE PRECISION XMIN,YMIN,XMAX,YMAX,DY,DX,Y1,Y0
!
      INTEGER H,W
      parameter(H=20,W=79)
!     H = HEIGHT, W = WIDTH
!
      IF (K > 0) WRITE(LUNIT,01) (P(I), I=1,K)
   01 FORMAT('Extra parameters',10f5.1)
      XMIN = X(1)
      XMAX = X(1)
      YMIN = Y(1)
      YMAX = Y(1)
      DO 10 I = 1, N
         XMIN = DMIN1(XMIN,X(I))
         XMAX = DMAX1(XMAX,X(I))
         YMIN = DMIN1(YMIN,Y(I))
         YMAX = DMAX1(YMAX,Y(I))
   10 CONTINUE
      DX = XMAX - XMIN
      IF (DX == 0.0D0) DX = 1.0D0
      DY = YMAX - YMIN
      WRITE(LUNIT,'(80X)')
      DO 40 L = 1, H
         BUF(:)=' '  ! blank out the line
         Y1 = YMIN + (H-L+1)*DY/H
         Y0 = YMIN + (H-L)*DY/H
         JMAX = 1
         DO 30 I = 1, N
            IF (Y(I) > Y1) GOTO 30
            IF (L/=H .AND. Y(I)<=Y0) GOTO 30
            J = 1 + (W-1)*(X(I) - XMIN)/DX
            BUF(J:J) = '*'
            JMAX = MAX0(JMAX,J)
   30    CONTINUE
         WRITE(LUNIT,'(1X,A)') BUF(1:JMAX)
   40 CONTINUE
      RETURN
      END SUBROUTINE PLOT
!-----------------------------------------------------------------------

      SUBROUTINE PRINT(ID,K)
!     PRIMARY OUTPUT ROUTINE
      INTEGER ID(4),K
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,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/
!     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/
      save fno, fnl
!     FMT   1       2       3       4       5
!         SHORT   LONG   SHORT E  LONG E    Z
!     TYP   1       2       3
!         INTEGER  REAL   COMPLEX
      IF (LCT(1) < 0) GOTO 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) /= TR) TYP = MAX0(2,TYP)
        IF (TI /= 0.0D0) TYP = 3
   10 CONTINUE
      IF (S /= 0.0D0) S = DLOG10(S)
      KS = IDINT(S)
      IF (-2 <= KS .AND. KS <= 1) KS = 0
      IF (KS == 2 .AND. FMT == 1 .AND. TYP == 2) KS = 0

      IF (TYP == 1 .AND. KS <= 2) F = 1
      IF (TYP == 1 .AND. KS > 2) F = 2

      IF (TYP == 1 .AND. KS > 9) TYP = 2
      IF (TYP == 2) F = FMT + 2
      IF (TYP == 3) F = FMT + 6
      IF (MN==1 .AND. KS/=0 .AND. FMT<3 .AND. TYP/=1) F = F+2
      IF (FMT == 5) F = 11

      JINC = FNL(F)
      F = FNO(F)
      S = 1.0D0
      IF (F==21 .OR. F==22 .OR. F==31 .OR. F==32) S = 10.0D0**KS
      LS = ((N-1)/JINC+1)*M + 2
      IF (LCT(1) + LS <= LCT(2)) GOTO 20
         LCT(1) = 0
         WRITE(WTE,43) LS
         READ(RTE,44,END=19) LS
!DC..    IF (EOF(RTE)/=0) GOTO 19
         IF (LS == ALFA(BLANK+1)) GOTO 20
         LCT(1) = -1
         GOTO 99
   19    CALL FILES(-RTE,BUF)
   20 CONTINUE
      WRITE(WTE,44)
      IF (WIO /= 0) WRITE(WIO,44)
      CALL PRNTID(ID,-1)
      LCT(1) = LCT(1)+2
      LUNIT = WTE
   50 IF (S /= 1.0D0) WRITE(LUNIT,41) S
      DO 80 J1 = 1, N, JINC
        J2 = MIN0(N, J1+JINC-1)
        WRITE(LUNIT,44)
        IF (N > 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) < 0.0D0) SIG(J) = ALFA(MINUS+1)
   60     CONTINUE
          IF (F == 11) WRITE(LUNIT,11)(PR(J),J=1,JM)
          IF (F == 12) WRITE(LUNIT,12)(PR(J),J=1,JM)
          IF (F == 21) WRITE(LUNIT,21)(PR(J),J=1,JM)
          IF (F == 22) WRITE(LUNIT,22)(PR(J),J=1,JM)
          IF (F == 23) WRITE(LUNIT,23)(PR(J),J=1,JM)
          IF (F == 24) WRITE(LUNIT,24)(PR(J),J=1,JM)
          IF (F == 31) WRITE(LUNIT,31)(PR(J),SIG(J),PI(J),J=1,JM)
          IF (F == 32) WRITE(LUNIT,32)(PR(J),SIG(J),PI(J),J=1,JM)
          IF (F == 33) WRITE(LUNIT,33)(PR(J),SIG(J),PI(J),J=1,JM)
          IF (F == 34) WRITE(LUNIT,34)(PR(J),SIG(J),PI(J),J=1,JM)
          IF (F == -1) CALL FORMZ(LUNIT,STKR(LS),STKI(LS))
          LCT(1) = LCT(1)+1
   70   CONTINUE
   80 CONTINUE
      IF (LUNIT==WIO .OR. WIO==0) GOTO 99
      LUNIT = WIO
      GOTO 50
   99 CONTINUE
      RETURN
!
   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)
!
      END SUBROUTINE PRINT

!-----------------------------------------------------------------------
      SUBROUTINE PRNTID(ID,ARGCNT)
!     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),CHRA,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,CHRA,FLP,FIN,FUN,LHS,RHS,RAN
      INTEGER EQUAL
      DATA EQUAL/46/
      save equal
      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 == -1) L=L+1
      IF (ARGCNT == -1) BUF(L) = ALFA(EQUAL+1)
      WRITE(WTE,20) (BUF(I),I=1,L)
      IF (WIO /= 0) WRITE(WIO,20) (BUF(I),I=1,L)
   20 FORMAT(1X,8(4A1,2H  ))
      J1 = J1+8
      IF (J1 <= IABS(ARGCNT)) GOTO 10
      RETURN
      END SUBROUTINE PRNTID

!-----------------------------------------------------------------------
      SUBROUTINE PROMPT(PAUSE)
      INTEGER PAUSE
!
!     ISSUE MATLAB PROMPT WITH OPTIONAL PAUSE
!
      INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
      COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
      WRITE(WTE,10)
      IF (WIO /= 0) WRITE(WIO,10)
   10 FORMAT(/1X,'<>',$)
      IF (PAUSE == 1) READ(RTE,20) DUMMY
   20 FORMAT(A1)
      RETURN
      END SUBROUTINE PROMPT

!-----------------------------------------------------------------------
      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 == 0.0D0) GOTO 20
      IF (DDT == 25) WRITE(WTE,1)
      IF (DDT == 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 == 4.0D0) GOTO 20
      S = R/T
      P = P + 2.0D0*P*S
      Q = Q*S
      IF (DDT == 25) WRITE(WTE,2) P,Q
      GOTO 10
   20 PYTHAG = P
      RETURN
      END FUNCTION PYTHAG

!-----------------------------------------------------------------------
      SUBROUTINE RAT(X,LEN,MAXD,A,B,D)
      INTEGER LEN,MAXD
      DOUBLE PRECISION X,A,B,D(LEN)
!
!     A/B = CONTINUED FRACTION APPROXIMATION TO X
!           USING  LEN  TERMS EACH LESS THAN MAXD
!
      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) <= 1.0D0) GOTO 20
         Z = 1.0D0/Z
   10 CONTINUE
   20 T = D(K)
      S = 1.0D0
      IF (K < 2) GOTO 40
      DO 30 IB = 2, K
         I = K+1-IB
         Z = T
         T = D(I)*T + S
         S = Z
   30 CONTINUE
   40 IF (S < 0.0D0) T = -T
      IF (S < 0.0D0) S = -S
      IF (DDT == 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 RAT

!-----------------------------------------------------------------------
      SUBROUTINE SAVLOD(LUNIT,ID,M,N,IMG,JOB,XREAL,XIMAG)
      INTEGER LUNIT,ID(4),M,N,IMG,JOB
      DOUBLE PRECISION XREAL(1),XIMAG(1)
!
!     IMPLEMENT SAVE AND LOAD
!     LUNIT = LOGICAL UNIT NUMBER
!     ID = NAME, FORMAT 4A1
!     M, N = DIMENSIONS
!     IMG = NONZERO IF XIMAG IS NONZERO
!     JOB = 0     FOR SAVE
!         = SPACE AVAILABLE FOR LOAD
!     XREAL, XIMAG = REAL AND OPTIONAL IMAGINARY PARTS
!
!     SYSTEM DEPENDENT FORMATS
  101 FORMAT(4A1,3I4)
  102 FORMAT(4Z18)
!
      IF (JOB > 0) GOTO 20
!
!     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 /= 0) WRITE(LUNIT,102) (XIMAG(I),I=K,L)
   15 CONTINUE
      RETURN
!
!     LOAD
   20 READ(LUNIT,101,END=30) ID,M,N,IMG
      IF (M*N > JOB) GOTO 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 /= 0) READ(LUNIT,102,END=30) (XIMAG(I),I=K,L)
   25 CONTINUE
      RETURN
!
!     END OF FILE
   30 M = 0
      N = 0
      RETURN
      END SUBROUTINE SAVLOD
!-----------------------------------------------------------------------
      SUBROUTINE STACK1(OP)
      INTEGER OP
!
!     UNARY OPERATIONS
!
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,FLP,FIN,FUN,LHS,RHS,RAN
      INTEGER QUOTE
      DATA QUOTE/49/
      save quote
      IF (DDT == 1) WRITE(WTE,100) OP
  100 FORMAT(1X,'STACK1',I4)
      L = LSTK(TOP)
      M = MSTK(TOP)
      N = NSTK(TOP)
      MN = M*N
      IF (MN == 0) GOTO 99
      IF (OP == QUOTE) GOTO 30
!
!     UNARY MINUS
      CALL WRSCAL(MN,-1.0D0,STKR(L),STKI(L),1)
      GOTO 99
!
!     TRANSPOSE
   30 LL = L + MN
      ERR = LL+MN - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 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
      GOTO 99
   99 RETURN
      END SUBROUTINE STACK1
!-----------------------------------------------------------------------
      SUBROUTINE STACK2(OP)
      INTEGER OP
!
!     BINARY AND TERNARY OPERATIONS
!
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,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/
      SAVE PLUS,MINUS,STAR,DSTAR,SLASH,BSLASH,DOT,COLON
!
      IF (DDT == 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 == PLUS) GOTO 01
      IF (OP == MINUS) GOTO 03
      IF (OP == STAR) GOTO 05
      IF (OP == DSTAR) GOTO 30
      IF (OP == SLASH) GOTO 20
      IF (OP == BSLASH) GOTO 25
      IF (OP == COLON) GOTO 60
      IF (OP > 2*DOT) GOTO 80
      IF (OP > DOT) GOTO 70
!
!     ADDITION
   01 IF (M < 0) GOTO 50
      IF (M2 < 0) GOTO 52
      IF (M /= M2) CALL ERROR(8)
      IF (ERR > 0) RETURN
      IF (N /= N2) CALL ERROR(8)
      IF (ERR > 0) RETURN
      CALL WAXPY(M*N,1.0D0,0.0D0,STKR(L2),STKI(L2),1,&
                  STKR(L),STKI(L),1)
      GOTO 99
!
!     SUBTRACTION
   03 IF (M < 0) GOTO 54
      IF (M2 < 0) GOTO 56
      IF (M /= M2) CALL ERROR(9)
      IF (ERR > 0) RETURN
      IF (N /= N2) CALL ERROR(9)
      IF (ERR > 0) RETURN
      CALL WAXPY(M*N,-1.0D0,0.0D0,STKR(L2),STKI(L2),1,&
                  STKR(L),STKI(L),1)
      GOTO 99
!
!     MULTIPLICATION
   05 IF (M2*M2*N2 == 1) GOTO 10
      IF (M*N == 1) GOTO 11
      IF (M2*N2 == 1) GOTO 10
      IF (N /= M2) CALL ERROR(10)
      IF (ERR > 0) RETURN
      MN = M*N2
      LL = L + MN
      ERR = LL+M*N+M2*N2 - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 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
      GOTO 99
!
!     MULTIPLICATION BY SCALAR
   10 SR = STKR(L2)
      SI = STKI(L2)
      L1 = L
      GOTO 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/=L)&
         CALL WCOPY(MN,STKR(L1),STKI(L1),1,STKR(L),STKI(L),1)
      GOTO 99
!
!     RIGHT DIVISION
   20 IF (M2*N2 == 1) GOTO 21
      IF (M2 == N2) FUN = 1
      IF (M2 /= N2) FUN = 4
      FIN = -1
      RHS = 2
      GOTO 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 > 0) RETURN
   22 CONTINUE
      GOTO 99
!
!     LEFT DIVISION
   25 IF (M*N == 1) GOTO 26
      IF (M == N) FUN = 1
      IF (M /= N) FUN = 4
      FIN = -2
      RHS = 2
      GOTO 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 > 0) RETURN
   27 CONTINUE
      GOTO 99
!
!     POWER
   30 IF (M2*N2 /= 1) CALL ERROR(30)
      IF (ERR > 0) RETURN
      IF (M /= N) CALL ERROR(20)
      IF (ERR > 0) RETURN
      NEXP = IDINT(STKR(L2))
      IF (STKR(L2) /= DFLOAT(NEXP)) GOTO 39
      IF (STKI(L2) /= 0.0D0) GOTO 39
      IF (NEXP < 2) GOTO 39
      MN = M*N
      ERR = L2+MN+N - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 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
      GOTO 99
!
!     NONINTEGER OR NONPOSITIVE POWER, USE EIGENVECTORS
   39 FUN = 2
      FIN = 0
      GOTO 99
!
!     ADD OR SUBTRACT SCALAR
   50 IF (M2 /= N2) CALL ERROR(8)
      IF (ERR > 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)
      GOTO 58
   52 IF (M /= N) CALL ERROR(8)
      IF (ERR > 0) RETURN
      SR = STKR(L2)
      SI = STKI(L2)
      GOTO 58
   54 IF (M2 /= N2) CALL ERROR(9)
      IF (ERR > 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)
      GOTO 58
   56 IF (M /= N) CALL ERROR(9)
      IF (ERR > 0) RETURN
      SR = -STKR(L2)
      SI = -STKI(L2)
      GOTO 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
      GOTO 99
!
!     COLON
   60 E2 = STKR(L2)
      ST = 1.0D0
      N = 0
      IF (RHS < 3) GOTO 61
      ST = STKR(L)
      TOP = TOP-1
      L = LSTK(TOP)
      IF (ST == 0.0D0) GOTO 63
   61 E1 = STKR(L)
!     CHECK FOR CLAUSE
      IF (RSTK(PT) == 3) GOTO 64
      ERR = L + MAX0(3,IDINT((E2-E1)/ST)) - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 0) RETURN
   62 IF (ST > 0.0D0 .AND. STKR(L) > E2) GOTO 63
      IF (ST < 0.0D0 .AND. STKR(L) < E2) GOTO 63
        N = N+1
        L = L+1
        STKR(L) = E1 + DFLOAT(N)*ST
        STKI(L) = 0.0D0
        GOTO 62
   63 NSTK(TOP) = N
      MSTK(TOP) = 1
      IF (N == 0) MSTK(TOP) = 0
      GOTO 99
!
!     FOR CLAUSE
   64 STKR(L) = E1
      STKR(L+1) = ST
      STKR(L+2) = E2
      MSTK(TOP) = -3
      NSTK(TOP) = -1
      GOTO 99
!
!     ELEMENTWISE OPERATIONS
   70 OP = OP - DOT
      IF (M/=M2 .OR. N/=N2) CALL ERROR(10)
      IF (ERR > 0) RETURN
      MN = M*N
      DO 72 I = 1, MN
         J = L+I-1
         K = L2+I-1
         IF (OP == STAR)&
            CALL WMUL(STKR(J),STKI(J),STKR(K),STKI(K),STKR(J),STKI(J))
         IF (OP == SLASH)&
            CALL WDIV(STKR(J),STKI(J),STKR(K),STKI(K),STKR(J),STKI(J))
         IF (OP == BSLASH)&
            CALL WDIV(STKR(K),STKI(K),STKR(J),STKI(J),STKR(J),STKI(J))
         IF (ERR > 0) RETURN
   72 CONTINUE
      GOTO 99
!
!     KRONECKER
   80 FIN = OP - 2*DOT - STAR + 11
      FUN = 6
      TOP = TOP + 1
      RHS = 2
      GOTO 99
!
   99 RETURN
      END SUBROUTINE STACK2

!-----------------------------------------------------------------------
      SUBROUTINE STACKG(ID)
      INTEGER ID(4)
!
!     GET VARIABLES FROM STORAGE
!
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,FLP,FIN,FUN,LHS,RHS,RAN
      LOGICAL EQID
      IF (DDT == 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)) GOTO 10
      IF (K >= LSIZE-1 .AND. RHS > 0) GOTO 98
      IF (K == BOT-1) GOTO 98
      LK = LSTK(K)
      IF (RHS == 1) GOTO 40
      IF (RHS == 2) GOTO 60
      IF (RHS > 2) CALL ERROR(21)
      IF (ERR > 0) RETURN
      L = 1
      IF (TOP > 0) L = LSTK(TOP) + MSTK(TOP)*NSTK(TOP)
      IF (TOP+1 >= BOT) CALL ERROR(18)
      IF (ERR > 0) RETURN
      TOP = TOP+1
!
!     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 > 0) CALL ERROR(17)
      IF (ERR > 0) RETURN
!     IF RAND, MATFN6 GENERATES RANDOM NUMBER
      IF (K == LSIZE) GOTO 97
      CALL WCOPY(MN,STKR(LK),STKI(LK),1,STKR(L),STKI(L),1)
      GOTO 99
!
!     VECT(ARG)
   40 IF (MSTK(TOP) == 0) GOTO 99
      L = LSTK(TOP)
      MN = MSTK(TOP)*NSTK(TOP)
      MNK = MSTK(K)*NSTK(K)
      IF (MSTK(TOP) < 0) MN = MNK
      DO 50 I = 1, MN
        LL = L+I-1
        LS = LK+I-1
        IF (MSTK(TOP) > 0) LS = LK + IDINT(STKR(LL)) - 1
        IF (LS < LK .OR. LS >= LK+MNK) CALL ERROR(21)
        IF (ERR > 0) RETURN
        STKR(LL) = STKR(LS)
        STKI(LL) = STKI(LS)
   50 CONTINUE
      MSTK(TOP) = 1
      NSTK(TOP) = 1
      IF (MSTK(K) > 1) MSTK(TOP) = MN
      IF (MSTK(K) == 1) NSTK(TOP) = MN
      GOTO 99
!
!     MATRIX(ARG,ARG)
   60 TOP = TOP-1
      L = LSTK(TOP)
      IF (MSTK(TOP+1) == 0) MSTK(TOP) = 0
      IF (MSTK(TOP) == 0) GOTO 99
      L2 = LSTK(TOP+1)
      M = MSTK(TOP)*NSTK(TOP)
      IF (MSTK(TOP) < 0) M = MSTK(K)
      N = MSTK(TOP+1)*NSTK(TOP+1)
      IF (MSTK(TOP+1) < 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) > 0) LI = L + IDINT(STKR(LI)) - 1
        LJ = L2+J-1
        IF (MSTK(TOP+1) > 0) LJ = L2 + IDINT(STKR(LJ)) - 1
        LS = LK + LI-L + (LJ-L2)*MK
        IF (LS<LK .OR. LS>=LK+MNK) CALL ERROR(21)
        IF (ERR > 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
      GOTO 99
   97 FIN = 7
      FUN = 6
      RETURN
   98 FIN = 0
      RETURN
   99 FIN = -1
      FUN = 0
      RETURN
      END SUBROUTINE STACKG

!-----------------------------------------------------------------------
      SUBROUTINE STACKP(ID)
      INTEGER ID(4)
!
!     PUT VARIABLES INTO STORAGE
!
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,FLP,FIN,FUN,LHS,RHS,RAN
      LOGICAL EQID
      INTEGER SEMI
      DATA SEMI/39/
      save semi
      IF (DDT == 1) WRITE(WTE,100) ID
  100 FORMAT(1X,'STACKP',4I4)
      IF (TOP <= 0) CALL ERROR(1)
      IF (ERR > 0) RETURN
      CALL FUNS(ID)
      IF (FIN /= 0) CALL ERROR(25)
      IF (ERR > 0) RETURN
      M = MSTK(TOP)
      N = NSTK(TOP)
      IF (M > 0) L = LSTK(TOP)
      IF (M < 0) CALL ERROR(14)
      IF (ERR > 0) RETURN
      IF (M == 0 .AND. N /= 0) GOTO 99
      MN = M*N
      LK = 0
      MK = 1
      NK = 0
      LT = 0
      MT = 0
      NT = 0
!
!     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)) GOTO 05
      IF (K == BOT-1) GOTO 30
      LK = LSTK(K)
      MK = MSTK(K)
      NK = NSTK(K)
      MNK = MK*NK
      IF (RHS == 0) GOTO 20
      IF (RHS > 2) CALL ERROR(15)
      IF (ERR > 0) RETURN
      MT = MK
      NT = NK
      LT = L + MN
      ERR = LT + MNK - LSTK(BOT)
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 0) RETURN
      CALL WCOPY(MNK,STKR(LK),STKI(LK),1,STKR(LT),STKI(LT),1)
!
!     DOES IT FIT
   20 IF (RHS==0 .AND. MN==MNK) GOTO 40
      IF (K >= LSIZE-3) CALL ERROR(13)
      IF (ERR > 0) RETURN
!
!     SHIFT STORAGE
      IF (K == BOT) GOTO 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
!
!     DESTROY OLD VARIABLE
   25 BOT = BOT+1
!
!     CREATE NEW VARIABLE
   30 IF (MN == 0) GOTO 99
      IF (BOT-2 <= TOP) CALL ERROR(18)
      IF (ERR > 0) RETURN
      K = BOT-1
      CALL PUTID(IDSTK(1,K), ID)
      IF (RHS == 1) GOTO 50
      IF (RHS == 2) GOTO 55
!
!     STORE
   40 IF (K < 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)
      GOTO 90
!
!     VECT(ARG)
   50 IF (MSTK(TOP-1) < 0) GOTO 59
      MN1 = 1
      MN2 = 1
      L1 = 0
      L2 = 0
      IF (N/=1 .OR. NK/=1) GOTO 52
      L1 = LSTK(TOP-1)
      M1 = MSTK(TOP-1)
      MN1 = M1*NSTK(TOP-1)
      M2 = -1
      GOTO 60
   52 IF (M/=1 .OR. MK/=1) CALL ERROR(15)
      IF (ERR > 0) RETURN
      L2 = LSTK(TOP-1)
      M2 = MSTK(TOP-1)
      MN2 = M2*NSTK(TOP-1)
      M1 = -1
      GOTO 60
!
!     MATRIX(ARG,ARG)
   55 IF (MSTK(TOP-1)<0 .AND. MSTK(TOP-2)<0) GOTO 59
      L2 = LSTK(TOP-1)
      M2 = MSTK(TOP-1)
      MN2 = M2*NSTK(TOP-1)
      IF (M2 < 0) MN2 = N
      L1 = LSTK(TOP-2)
      M1 = MSTK(TOP-2)
      MN1 = M1*NSTK(TOP-2)
      IF (M1 < 0) MN1 = M
      GOTO 60
!
   59 IF (MN /= MNK) CALL ERROR(15)
      IF (ERR > 0) RETURN
      LK = LSTK(K)
      CALL WCOPY(MN,STKR(L),STKI(L),-1,STKR(LK),STKI(LK),-1)
      GOTO 90
!
   60 IF (MN1/=M .OR. MN2/=N) CALL ERROR(15)
      IF (ERR > 0) RETURN
      LL = 1
      IF (M1 < 0) GOTO 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 < 0) GOTO 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 < 1) CALL ERROR(21)
      IF (ERR > 0) RETURN
      MNK = MK*NK
      LK = LSTK(K+1) - MNK
      ERR = LT + MT*NT - LK
      IF (ERR > 0) CALL ERROR(17)
      IF (ERR > 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 < 1) GOTO 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 > 0) LI = L1 + IDINT(STKR(LI)) - 1
        LJ = L2+J-1
        IF (M2 > 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
      GOTO 90
!
!     PRINT IF DESIRED AND POP STACK
   90 IF (SYM/=SEMI .AND. LCT(3)==0) CALL PRINT(ID,K)
      IF (SYM==SEMI .AND. LCT(3)==1) CALL PRINT(ID,K)
      IF (K == BOT-1) BOT = BOT-1
   99 IF (M /= 0) TOP = TOP - 1 - RHS
      IF (M == 0) TOP = TOP - 1
      RETURN
      END SUBROUTINE STACKP

!-----------------------------------------------------------------------
      SUBROUTINE TERM
      DOUBLE PRECISION STKR(50505),STKI(50505)
      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),CHRA,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,CHRA,FLP,FIN,FUN,LHS,RHS,RAN
      INTEGER R,OP,BSLASH,STAR,SLASH,DOT
      DATA BSLASH/45/,STAR/43/,SLASH/44/,DOT/47/
      save bslash,star,slash,dot
      IF (DDT == 1) WRITE(WTE,100) PT,RSTK(PT)
  100 FORMAT(1X,'TERM  ',2I4)
      R = RSTK(PT)
      GOTO (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
!     *CALL* FACTOR
      RETURN
   05 PT = PT-1
   10 OP = 0
      IF (SYM == DOT) OP = DOT
      IF (SYM == DOT) CALL GETSYM
      IF (SYM==STAR .OR. SYM==SLASH .OR. SYM==BSLASH) GOTO 20
      RETURN
   20 OP = OP + SYM
      CALL GETSYM
      IF (SYM == DOT) OP = OP + SYM
      IF (SYM == DOT) CALL GETSYM
      PT = PT+1
      PSTK(PT) = OP
      RSTK(PT) = 9
!     *CALL* FACTOR
      RETURN
   25 OP = PSTK(PT)
      PT = PT-1
      CALL STACK2(OP)
      IF (ERR > 0) RETURN
!     SOME BINARY OPS DONE IN MATFNS
      IF (FUN == 0) GOTO 10
      PT = PT+1
      RSTK(PT) = 15
!     *CALL* MATFN
      RETURN
   35 PT = PT-1
      GOTO 10
   99 CALL ERROR(22)
      IF (ERR > 0) RETURN
      RETURN
      END SUBROUTINE TERM

!-----------------------------------------------------------------------
      SUBROUTINE USER00(A,M,N,S,T)
      DOUBLE PRECISION A(M,N),S,T
!
      INTEGER A3(9)
      DATA A3 /-149,537,-27,-50,180,-9,-154,546,-25/
      save a3
      IF (A(1,1) /= 3.0D0) RETURN
      DO 10 I = 1, 9
         A(I,1) = DFLOAT(A3(I))
   10 CONTINUE
      M = 3
      N = 3
      RETURN
      END SUBROUTINE USER00
!-----------------------------------------------------------------------
      SUBROUTINE USER(A,M,N,S,T)
      DOUBLE PRECISION A(M,N),S,T
!
      write(*,*)'USER'
      DO I = 1,m
         do J = 1,n
            A(I,J) =A(I,J)+1
         enddo
      enddo
      M = M
      N = N
      RETURN
      END SUBROUTINE USER

!-----------------------------------------------------------------------
      SUBROUTINE XCHAR(BUF,K)
      INTEGER BUF(*),K
!     SYSTEM DEPENDENT ROUTINE TO HANDLE SPECIAL CHARACTERS
      INTEGER BACK,MASK
      DATA BACK/Z'20202008'/,MASK/Z'000000FF'/
      save back, mask
!
      IF (BUF(1) == BACK) K = -1
      !L = BUF(1) .AND. MASK
      !IF(BUF(1)<30.OR.BUF(1)>70)
      L = IAND(BUF(1),MASK)
      IF (K /= -1) WRITE(6,10) BUF(1),L
   10 FORMAT(1X,1H',A1,4H' = ,Z2,' hex is not a MATLAB character.')
      RETURN
      END SUBROUTINE XCHAR
!-----------------------------------------------------------------------
      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
!
!     WGECO FACTORS A DOUBLE-COMPLEX MATRIX BY GAUSSIAN ELIMINATION
!     AND ESTIMATES THE CONDITION OF THE MATRIX.
!
!     IF  RCOND  IS NOT NEEDED, WGEFA IS SLIGHTLY FASTER.
!     TO SOLVE  A*X = B , FOLLOW WGECO BY WGESL.
!     TO COMPUTE  INVERSE(A)*C , FOLLOW WGECO BY WGESL.
!     TO COMPUTE  DETERMINANT(A) , FOLLOW WGECO BY WGEDI.
!     TO COMPUTE  INVERSE(A) , FOLLOW WGECO BY WGEDI.
!
!     ON ENTRY
!
!        A       DOUBLE-COMPLEX(LDA, N)
!                THE MATRIX TO BE FACTORED.
!
!        LDA     INTEGER
!                THE LEADING DIMENSION OF THE ARRAY  A .
!
!        N       INTEGER
!                THE ORDER OF THE MATRIX  A .
!
!     ON RETURN
!
!        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
!                WHICH WERE USED TO OBTAIN IT.
!                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
!                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
!                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
!
!        IPVT    INTEGER(N)
!                AN INTEGER VECTOR OF PIVOT INDICES.
!
!        RCOND   DOUBLE PRECISION
!                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  A .
!                FOR THE SYSTEM  A*X = B , RELATIVE PERTURBATIONS
!                IN  A  AND  B  OF SIZE  EPSILON  MAY CAUSE
!                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND .
!                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION
!        1.0 + RCOND == 1.0
!                IS TRUE, THEN  A  MAY BE SINGULAR TO WORKING
!                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF
!                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
!                UNDERFLOWS.
!
!        Z       DOUBLE-COMPLEX(N)
!                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
!                IF  A  IS CLOSE TO A SINGULAR MATRIX, THEN  Z  IS
!                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
!                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
!
!     LINPACK. THIS VERSION DATED 07/01/79 .
!     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
!
!     SUBROUTINES AND FUNCTIONS
!
!     LINPACK WGEFA
!     BLAS WAXPY,WDOTC,WASUM
!     FORTRAN DABS,DMAX1
!
!     INTERNAL VARIABLES
!
      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
!
      DOUBLE PRECISION ZDUMR,ZDUMI
      DOUBLE PRECISION CABS1
      CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
!
!     COMPUTE 1-NORM OF A
!
      ANORM = 0.0D0
      DO 10 J = 1, N
         ANORM = DMAX1(ANORM,WASUM(N,AR(1,J),AI(1,J),1))
   10 CONTINUE
!
!     FACTOR
!
      CALL WGEFA(AR,AI,LDA,N,IPVT,INFO)
!
!     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
!     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  CTRANS(A)*Y = E .
!     CTRANS(A)  IS THE CONJUGATE TRANSPOSE OF A .
!     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
!     GROWTH IN THE ELEMENTS OF W  WHERE  CTRANS(U)*W = E .
!     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
!
!     SOLVE CTRANS(U)*W = E
!
      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))&
             <= CABS1(AR(K,K),AI(K,K))) GOTO 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)) == 0.0D0) GOTO 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)
         GOTO 60
   50    CONTINUE
            WKR = 1.0D0
            WKI = 0.0D0
            WKMR = 1.0D0
            WKMI = 0.0D0
   60    CONTINUE
         KP1 = K + 1
         IF (KP1 > N) GOTO 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 >= SM) GOTO 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)
!
!     SOLVE CTRANS(L)*Y = W
!
      DO 140 KB = 1, N
         K = N + 1 - KB
         IF (K >= N) GOTO 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)) <= 1.0D0) GOTO 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)
!
      YNORM = 1.0D0
!
!     SOLVE L*V = Y
!
      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 < 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)) <= 1.0D0) GOTO 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
!
!     SOLVE  U*Z = V
!
      DO 200 KB = 1, N
         K = N + 1 - KB
         IF (CABS1(ZR(K),ZI(K))&
             <= CABS1(AR(K,K),AI(K,K))) GOTO 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)) == 0.0D0) GOTO 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)) /= 0.0D0) GOTO 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
!     MAKE ZNORM = 1.0
      S = 1.0D0/WASUM(N,ZR,ZI,1)
      CALL WRSCAL(N,S,ZR,ZI,1)
      YNORM = S*YNORM
!
      IF (ANORM /= 0.0D0) RCOND = YNORM/ANORM
      IF (ANORM == 0.0D0) RCOND = 0.0D0
      RETURN
      END SUBROUTINE WGECO
!-----------------------------------------------------------------------
      SUBROUTINE WGEFA(AR,AI,LDA,N,IPVT,INFO)
      INTEGER LDA,N,IPVT(1),INFO
      DOUBLE PRECISION AR(LDA,1),AI(LDA,1)
!
!     WGEFA FACTORS A DOUBLE-COMPLEX MATRIX BY GAUSSIAN ELIMINATION.
!
!     WGEFA IS USUALLY CALLED BY WGECO, BUT IT CAN BE CALLED
!     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
!     (TIME FOR WGECO) = (1 + 9/N)*(TIME FOR WGEFA) .
!
!     ON ENTRY
!
!        A       DOUBLE-COMPLEX(LDA, N)
!                THE MATRIX TO BE FACTORED.
!
!        LDA     INTEGER
!                THE LEADING DIMENSION OF THE ARRAY  A .
!
!        N       INTEGER
!                THE ORDER OF THE MATRIX  A .
!
!     ON RETURN
!
!        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
!                WHICH WERE USED TO OBTAIN IT.
!                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
!                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
!                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
!
!        IPVT    INTEGER(N)
!                AN INTEGER VECTOR OF PIVOT INDICES.
!
!        INFO    INTEGER
!                = 0  NORMAL VALUE.
!                = K  IF  U(K,K) == 0.0 .  THIS IS NOT AN ERROR
!  CONDITION FOR THIS SUBROUTINE, BUT IT DOES
!  INDICATE THAT WGESL OR WGEDI WILL DIVIDE BY ZERO
!  IF CALLED.  USE  RCOND  IN WGECO FOR A RELIABLE
!  INDICATION OF SINGULARITY.
!
!     LINPACK. THIS VERSION DATED 07/01/79 .
!     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
!
!     SUBROUTINES AND FUNCTIONS
!
!     BLAS WAXPY,WSCAL,IWAMAX
!     FORTRAN DABS
!
!     INTERNAL VARIABLES
!
      DOUBLE PRECISION TR,TI
      INTEGER IWAMAX,J,K,KP1,L,NM1
!
      DOUBLE PRECISION ZDUMR,ZDUMI
      DOUBLE PRECISION CABS1
      CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
!
!     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
!
      INFO = 0
      NM1 = N - 1
      IF (NM1 < 1) GOTO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
!
!        FIND L = PIVOT INDEX
!
         L = IWAMAX(N-K+1,AR(K,K),AI(K,K),1) + K - 1
         IPVT(K) = L
!
!        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
!
         IF (CABS1(AR(L,K),AI(L,K)) == 0.0D0) GOTO 40
!
!           INTERCHANGE IF NECESSARY
!
            IF (L == K) GOTO 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
!
!           COMPUTE MULTIPLIERS
!
            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)
!
!           ROW ELIMINATION WITH COLUMN INDEXING
!
            DO 30 J = KP1, N
               TR = AR(L,J)
               TI = AI(L,J)
               IF (L == K) GOTO 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
         GOTO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (CABS1(AR(N,N),AI(N,N)) == 0.0D0) INFO = N
      RETURN
      END SUBROUTINE WGEFA
!-----------------------------------------------------------------------
      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)
!
!     WGESL SOLVES THE DOUBLE-COMPLEX SYSTEM
!     A * X = B  OR  CTRANS(A) * X = B
!     USING THE FACTORS COMPUTED BY WGECO OR WGEFA.
!
!     ON ENTRY
!
!        A       DOUBLE-COMPLEX(LDA, N)
!                THE OUTPUT FROM WGECO OR WGEFA.
!
!        LDA     INTEGER
!                THE LEADING DIMENSION OF THE ARRAY  A .
!
!        N       INTEGER
!                THE ORDER OF THE MATRIX  A .
!
!        IPVT    INTEGER(N)
!                THE PIVOT VECTOR FROM WGECO OR WGEFA.
!
!        B       DOUBLE-COMPLEX(N)
!                THE RIGHT HAND SIDE VECTOR.
!
!        JOB     INTEGER
!                = 0         TO SOLVE  A*X = B ,
!                = NONZERO   TO SOLVE  CTRANS(A)*X = B  WHERE
!         CTRANS(A)  IS THE CONJUGATE TRANSPOSE.
!
!     ON RETURN
!
!        B       THE SOLUTION VECTOR  X .
!
!     ERROR CONDITION
!
!        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
!        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
!        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
!        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
!        CALLED CORRECTLY AND IF WGECO HAS SET RCOND > 0.0
!        OR WGEFA HAS SET INFO == 0 .
!
!     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
!     WITH  P  COLUMNS
!           CALL WGECO(A,LDA,N,IPVT,RCOND,Z)
!           IF (RCOND IS TOO SMALL) GOTO ...
!           DO 10 J = 1, P
!              CALL WGESL(A,LDA,N,IPVT,C(1,J),0)
!        10 CONTINUE
!
!     LINPACK. THIS VERSION DATED 07/01/79 .
!     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
!
!     SUBROUTINES AND FUNCTIONS
!
!     BLAS WAXPY,WDOTC
!
!     INTERNAL VARIABLES
!
      DOUBLE PRECISION WDOTCR,WDOTCI,TR,TI
      INTEGER K,KB,L,NM1
!
      NM1 = N - 1
      IF (JOB /= 0) GOTO 50
!
!        JOB = 0 , SOLVE  A * X = B
!        FIRST SOLVE  L*Y = B
!
         IF (NM1 < 1) GOTO 30
         DO 20 K = 1, NM1
            L = IPVT(K)
            TR = BR(L)
            TI = BI(L)
            IF (L == K) GOTO 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
!
!        NOW SOLVE  U*X = Y
!
         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
      GOTO 100
   50 CONTINUE
!
!        JOB = NONZERO, SOLVE  CTRANS(A) * X = B
!        FIRST SOLVE  CTRANS(U)*Y = B
!
         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
!
!        NOW SOLVE CTRANS(L)*X = Y
!
         IF (NM1 < 1) GOTO 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 == K) GOTO 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 WGESL
!-----------------------------------------------------------------------
      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)
!
!     WGEDI COMPUTES THE DETERMINANT AND INVERSE OF A MATRIX
!     USING THE FACTORS COMPUTED BY WGECO OR WGEFA.
!
!     ON ENTRY
!
!        A       DOUBLE-COMPLEX(LDA, N)
!                THE OUTPUT FROM WGECO OR WGEFA.
!
!        LDA     INTEGER
!                THE LEADING DIMENSION OF THE ARRAY  A .
!
!        N       INTEGER
!                THE ORDER OF THE MATRIX  A .
!
!        IPVT    INTEGER(N)
!                THE PIVOT VECTOR FROM WGECO OR WGEFA.
!
!        WORK    DOUBLE-COMPLEX(N)
!                WORK VECTOR.  CONTENTS DESTROYED.
!
!        JOB     INTEGER
!                = 11   BOTH DETERMINANT AND INVERSE.
!                = 01   INVERSE ONLY.
!                = 10   DETERMINANT ONLY.
!
!     ON RETURN
!
!        A       INVERSE OF ORIGINAL MATRIX IF REQUESTED.
!                OTHERWISE UNCHANGED.
!
!        DET     DOUBLE-COMPLEX(2)
!                DETERMINANT OF ORIGINAL MATRIX IF REQUESTED.
!                OTHERWISE NOT REFERENCED.
!                DETERMINANT = DET(1) * 10.0**DET(2)
!                WITH  1.0 <= CABS1(DET(1) < 10.0
!                OR  DET(1) == 0.0 .
!
!     ERROR CONDITION
!
!        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
!        A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED.
!        IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY
!        AND IF WGECO HAS SET RCOND > 0.0 OR WGEFA HAS SET
!        INFO == 0 .
!
!     LINPACK. THIS VERSION DATED 07/01/79 .
!     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
!
!     SUBROUTINES AND FUNCTIONS
!
!     BLAS WAXPY,WSCAL,WSWAP
!     FORTRAN DABS,MOD
!
!     INTERNAL VARIABLES
!
      DOUBLE PRECISION TR,TI
      DOUBLE PRECISION TEN
      INTEGER I,J,K,KB,KP1,L,NM1
!
      DOUBLE PRECISION ZDUMR,ZDUMI
      DOUBLE PRECISION CABS1
      CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
!
!     COMPUTE DETERMINANT
!
      IF (JOB/10 == 0) GOTO 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) == I) GOTO 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))
!           ...EXIT
!        ...EXIT
            IF (CABS1(DETR(1),DETI(1)) == 0.0D0) GOTO 70
   20       IF (CABS1(DETR(1),DETI(1)) >= 1.0D0) GOTO 30
               DETR(1) = TEN*DETR(1)
               DETI(1) = TEN*DETI(1)
               DETR(2) = DETR(2) - 1.0D0
               DETI(2) = DETI(2) - 0.0D0
            GOTO 20
   30       CONTINUE
   40       IF (CABS1(DETR(1),DETI(1)) < TEN) GOTO 50
               DETR(1) = DETR(1)/TEN
               DETI(1) = DETI(1)/TEN
               DETR(2) = DETR(2) + 1.0D0
               DETI(2) = DETI(2) + 0.0D0
            GOTO 40
   50       CONTINUE
   60    CONTINUE
   70    CONTINUE
   80 CONTINUE
!
!     COMPUTE INVERSE(U)
!
      IF (MOD(JOB,10) == 0) GOTO 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 < KP1) GOTO 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
!
!        FORM INVERSE(U)*INVERSE(L)
!
         NM1 = N - 1
         IF (NM1 < 1) GOTO 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 /= 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 WGEDI
!-----------------------------------------------------------------------
      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 < 1) GOTO 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<=0.0D0 .OR. AI(J,J)/=0.0D0) GOTO 40
         AR(J,J) = DSQRT(S)
   30 CONTINUE
      INFO = 0
   40 RETURN
      END SUBROUTINE WPOFA
!-----------------------------------------------------------------------
      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>M .OR. L>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)) > TOL) GOTO 30
         CALL WSET(M-K+1,0.0D0,0.0D0,AR(K,L),AI(K,L),1)
         L = L+1
         GOTO 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 /= 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
      GOTO 20
      END SUBROUTINE RREF
!-----------------------------------------------------------------------
      SUBROUTINE HILBER(A,LDA,N)
      DOUBLE PRECISION A(LDA,N)
!     GENERATE INVERSE HILBERT MATRIX
      DOUBLE PRECISION P,R
      P = DFLOAT(N)
      DO 20 I = 1, N
        IF (I/=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==N) GOTO 20
        IP1 = I+1
        DO 10 J = IP1, N
          R = (-1)*(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 HILBER
!-----------------------------------------------------------------------
      SUBROUTINE HTRIDI(NM,N,AR,AI,D,E,E2,TAU)
!
      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
!
!     THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
!     THE ALGOL PROCEDURE TRED1, NUM. MATH. 11, 181-195(1968)
!     BY MARTIN, REINSCH, AND WILKINSON.
!     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
!
!     THIS SUBROUTINE REDUCES A COMPLEX HERMITIAN MATRIX
!     TO A REAL SYMMETRIC TRIDIAGONAL MATRIX USING
!     UNITARY SIMILARITY TRANSFORMATIONS.
!
!     ON INPUT.
!
!        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
!          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
!          DIMENSION STATEMENT.
!
!        N IS THE ORDER OF THE MATRIX.
!
!        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
!          RESPECTIVELY, OF THE COMPLEX HERMITIAN INPUT MATRIX.
!          ONLY THE LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
!
!     ON OUTPUT.
!
!        AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
!          FORMATIONS USED IN THE REDUCTION IN THEIR FULL LOWER
!          TRIANGLES.  THEIR STRICT UPPER TRIANGLES AND THE
!          DIAGONAL OF AR ARE UNALTERED.
!
!        D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX.
!
!        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
!          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO.
!
!        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
!          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
!
!        TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
!
!     MODIFIED TO GET RID OF ALL COMPLEX ARITHMETIC, C. MOLER, 6/27/79.
!
!     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
!     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
!
!     ------------------------------------------------------------------
!
      TAU(1,N) = 1.0D0
      TAU(2,N) = 0.0D0
!
      DO 100 I = 1, N
  100 D(I) = AR(I,I)
!     .......... 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 < 1) GOTO 130
!     .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
         DO 120 K = 1, L
  120    SCALE = FLOP(SCALE + DABS(AR(I,K)) + DABS(AI(I,K)))
!
         IF (SCALE /= 0.0D0) GOTO 140
         TAU(1,L) = 1.0D0
         TAU(2,L) = 0.0D0
  130    E(I) = 0.0D0
         E2(I) = 0.0D0
         GOTO 290
!
  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
!
         E2(I) = FLOP(SCALE*SCALE*H)
         G = FLOP(DSQRT(H))
         E(I) = FLOP(SCALE*G)
         F = PYTHAG(AR(I,L),AI(I,L))
!     .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T ..........
         IF (F == 0.0D0) GOTO 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 == 1) GOTO 270
         GOTO 170
  160    TAU(1,L) = -TAU(1,I)
         SI = TAU(2,I)
         AR(I,L) = G
  170    F = 0.0D0
!
         DO 240 J = 1, L
            G = 0.0D0
            GI = 0.0D0
!     .......... 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
!
            JP1 = J + 1
            IF (L < JP1) GOTO 220
!
            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
!     .......... 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
!
         HH = FLOP(F/(H + H))
!     .......... 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
!
            DO 260 K = 1, J
               AR(J,K) = FLOP(AR(J,K) - F*E(K) - G*AR(I,K)&
              + FI*TAU(2,K) + GI*AI(I,K))
               AI(J,K) = FLOP(AI(J,K) - F*TAU(2,K) - G*AI(I,K)&
              - FI*E(K) - GI*AR(I,K))
  260    CONTINUE
!
  270    DO 280 K = 1, L
            AR(I,K) = FLOP(SCALE*AR(I,K))
            AI(I,K) = FLOP(SCALE*AI(I,K))
  280    CONTINUE
!
         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
!
      RETURN
      END SUBROUTINE HTRIDI
!-----------------------------------------------------------------------
      SUBROUTINE HTRIBK(NM,N,AR,AI,TAU,M,ZR,ZI)
!
      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
!
!     THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
!     THE ALGOL PROCEDURE TRBAK1, NUM. MATH. 11, 181-195(1968)
!     BY MARTIN, REINSCH, AND WILKINSON.
!     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
!
!     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN
!     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
!     REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY  HTRIDI.
!
!     ON INPUT.
!
!        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
!          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
!          DIMENSION STATEMENT.
!
!        N IS THE ORDER OF THE MATRIX.
!
!        AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
!          FORMATIONS USED IN THE REDUCTION BY  HTRIDI  IN THEIR
!          FULL LOWER TRIANGLES EXCEPT FOR THE DIAGONAL OF AR.
!
!        TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
!
!        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
!
!        ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
!          IN ITS FIRST M COLUMNS.
!
!     ON OUTPUT.
!
!        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
!          RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
!          IN THEIR FIRST M COLUMNS.
!
!     NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR
!     IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED.
!
!     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
!     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
!
!     ------------------------------------------------------------------
!
      IF (M == 0) GOTO 200
!     .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC
!                TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN
!                TRIDIAGONAL MATRIX. ..........
      DO 50 K = 1, N
!
         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
!
      IF (N == 1) GOTO 200
!     .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES ..........
      DO 140 I = 2, N
         L = I - 1
         H = AI(I,I)
         IF (H == 0.0D0) GOTO 140
!
         DO 130 J = 1, M
            S = 0.0D0
            SI = 0.0D0
!
            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
!     .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW ..........
            S = FLOP((S/H)/H)
            SI = FLOP((SI/H)/H)
!
            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
!
  130    CONTINUE
!
  140 CONTINUE
!
  200 RETURN
      END SUBROUTINE HTRIBK
!-----------------------------------------------------------------------
      SUBROUTINE IMTQL2(NM,N,D,E,Z,IERR,JOB)
!
      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
!
!     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL2,
!     NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON,
!     AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
!     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
!
!     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
!     OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD.
!     THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
!     BE FOUND IF  TRED2  HAS BEEN USED TO REDUCE THIS
!     FULL MATRIX TO TRIDIAGONAL FORM.
!
!     ON INPUT.
!
!        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
!          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
!          DIMENSION STATEMENT.
!
!        N IS THE ORDER OF THE MATRIX.
!
!        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
!
!        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
!          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY.
!
!        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
!          REDUCTION BY  TRED2, IF PERFORMED.  IF THE EIGENVECTORS
!          OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
!          THE IDENTITY MATRIX.
!
!      ON OUTPUT.
!
!        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
!          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
!          UNORDERED FOR INDICES 1,2,...,IERR-1.
!
!        E HAS BEEN DESTROYED.
!
!        Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
!          TRIDIAGONAL (OR FULL) MATRIX.  IF AN ERROR EXIT IS MADE,
!          Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
!          EIGENVALUES.
!
!        IERR IS SET TO
!          ZERO       FOR NORMAL RETURN,
!          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
!  DETERMINED AFTER 30 ITERATIONS.
!
!     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
!     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
!
!     ------------------------------------------------------------------
!
!
!*****
!     MODIFIED BY C. MOLER TO ELIMINATE MACHEP 11/22/78
!     MODIFIED TO ADD JOB PARAMETER 08/27/79
!*****
      IERR = 0
      IF (N == 1) GOTO 1001
!
      DO 100 I = 2, N
  100 E(I-1) = E(I)
!
      E(N) = 0.0D0
!
      DO 240 L = 1, N
         J = 0
!     .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
  105    DO 110 M = L, N
            IF (M == N) GOTO 120
!*****
            P = FLOP(DABS(D(M)) + DABS(D(M+1)))
            S = FLOP(P + DABS(E(M)))
            IF (P == S) GOTO 120
!*****
  110    CONTINUE
!
  120    P = D(L)
         IF (M == L) GOTO 240
         IF (J == 30) GOTO 1000
         J = J + 1
!     .......... 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
!     .......... 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) < DABS(G)) GOTO 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)
            GOTO 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 == 0) GOTO 185
!     .......... 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
!
  200    CONTINUE
!
         D(L) = FLOP(D(L) - P)
         E(L) = G
         E(M) = 0.0D0
         GOTO 105
  240 CONTINUE
!     .......... ORDER EIGENVALUES AND EIGENVECTORS ..........
      DO 300 II = 2, N
         I = II - 1
         K = I
         P = D(I)
!
         DO 260 J = II, N
            IF (D(J) >= P) GOTO 260
            K = J
            P = D(J)
  260    CONTINUE
!
         IF (K == I) GOTO 300
         D(K) = D(I)
         D(I) = P
!
         IF (JOB == 0) GOTO 285
         DO 280 J = 1, N
            P = Z(J,I)
            Z(J,I) = Z(J,K)
            Z(J,K) = P
  280    CONTINUE
  285    CONTINUE
!
  300 CONTINUE
!
      GOTO 1001
!     .......... SET ERROR -- NO CONVERGENCE TO AN
!                EIGENVALUE AFTER 30 ITERATIONS ..........
 1000 IERR = L
 1001 RETURN
      END SUBROUTINE IMTQL2
!-----------------------------------------------------------------------
      SUBROUTINE CORTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
!
      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
!
!     THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
!     THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
!     BY MARTIN AND WILKINSON.
!     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
!
!     GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
!     REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
!     LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
!     UNITARY SIMILARITY TRANSFORMATIONS.
!
!     ON INPUT.
!
!        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
!          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
!          DIMENSION STATEMENT.
!
!        N IS THE ORDER OF THE MATRIX.
!
!        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
!          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
!          SET LOW=1, IGH=N.
!
!        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
!          RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
!
!     ON OUTPUT.
!
!        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
!          RESPECTIVELY, OF THE HESSENBERG MATRIX.  INFORMATION
!          ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
!          IS STORED IN THE REMAINING TRIANGLES UNDER THE
!          HESSENBERG MATRIX.
!
!        ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
!          TRANSFORMATIONS.  ONLY ELEMENTS LOW THROUGH IGH ARE USED.
!
!     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
!     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
!
!     ------------------------------------------------------------------
!
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA < KP1) GOTO 200
!
      DO 180 M = KP1, LA
         H = 0.0D0
         ORTR(M) = 0.0D0
         ORTI(M) = 0.0D0
         SCALE = 0.0D0
!     .......... 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)))
!
         IF (SCALE == 0.0D0) GOTO 180
         MP = M + IGH
!     .......... 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
!
         G = FLOP(DSQRT(H))
         F = PYTHAG(ORTR(M),ORTI(M))
         IF (F == 0.0D0) GOTO 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))
         GOTO 105
!
  103    ORTR(M) = G
         AR(M,M-1) = SCALE
!     .......... FORM (I-(U*UT)/H)*A ..........
  105    DO 130 J = M, N
            FR = 0.0D0
            FI = 0.0D0
!     .......... 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
!
            FR = FLOP(FR/H)
            FI = FLOP(FI/H)
!
            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
!
  130    CONTINUE
!     .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
         DO 160 I = 1, IGH
            FR = 0.0D0
            FI = 0.0D0
!     .......... 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
!
            FR = FLOP(FR/H)
            FI = FLOP(FI/H)
!
            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
!
  160    CONTINUE
!
         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
!
  200 RETURN
      END SUBROUTINE CORTH
!-----------------------------------------------------------------------
      SUBROUTINE COMQR3(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR&
                       ,JOB)
!*****
!     MODIFICATION OF EISPACK COMQR2 TO ADD JOB PARAMETER
!     JOB = 0  OUTPUT H = SCHUR TRIANGULAR FORM, Z NOT USED
!         = 1  OUTPUT H = SCHUR FORM, Z = UNITARY SIMILARITY
!         = 2  SAME AS COMQR2
!         = 3  OUTPUT H = HESSENBERG FORM, Z = UNITARY SIMILARITY
!     ALSO ELIMINATE MACHEP
!     C. MOLER, 11/22/78 AND 09/14/80
!     OVERFLOW CONTROL IN EIGENVECTOR BACKSUBSTITUTION, 3/16/82
!*****
!
      INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,&
              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),&
             ORTR(IGH),ORTI(IGH)
      DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM
      DOUBLE PRECISION FLOP,PYTHAG
!
!     THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
!     ALGOL PROCEDURE  COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
!     AND WILKINSON.
!     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
!     THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
!     (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
!
!     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
!     OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
!     METHOD.  THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
!     CAN ALSO BE FOUND IF  CORTH  HAS BEEN USED TO REDUCE
!     THIS GENERAL MATRIX TO HESSENBERG FORM.
!
!     ON INPUT.
!
!        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
!          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
!          DIMENSION STATEMENT.
!
!        N IS THE ORDER OF THE MATRIX.
!
!        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
!          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
!          SET LOW=1, IGH=N.
!
!        ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
!          FORMATIONS USED IN THE REDUCTION BY  CORTH, IF PERFORMED.
!          ONLY ELEMENTS LOW THROUGH IGH ARE USED.  IF THE EIGENVECTORS
!          OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
!          ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
!
!        HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
!          RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
!          THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
!          INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
!          REDUCTION BY  CORTH, IF PERFORMED.  IF THE EIGENVECTORS OF
!          THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
!          ARBITRARY.
!
!     ON OUTPUT.
!
!        ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
!          HAVE BEEN DESTROYED.
!
!        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
!          RESPECTIVELY, OF THE EIGENVALUES.  IF AN ERROR
!          EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
!          FOR INDICES IERR+1,...,N.
!
!        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
!          RESPECTIVELY, OF THE EIGENVECTORS.  THE EIGENVECTORS
!          ARE UNNORMALIZED.  IF AN ERROR EXIT IS MADE, NONE OF
!          THE EIGENVECTORS HAS BEEN FOUND.
!
!        IERR IS SET TO
!          ZERO       FOR NORMAL RETURN,
!          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
!  DETERMINED AFTER A TOTAL OF 30*N ITERATIONS.
!
!     MODIFIED TO GET RID OF ALL COMPLEX ARITHMETIC, C. MOLER, 6/27/79.
!
!     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
!     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
!
!     ------------------------------------------------------------------
!
      IERR = 0
!*****
      IF (JOB == 0) GOTO 150
!*****
!     .......... INITIALIZE EIGENVECTOR MATRIX ..........
      DO 100 I = 1, N
!
         DO 100 J = 1, N
            ZR(I,J) = 0.0D0
            ZI(I,J) = 0.0D0
            IF (I == J) ZR(I,J) = 1.0D0
  100 CONTINUE
!     .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
!                FROM THE INFORMATION LEFT BY CORTH ..........
      IEND = IGH - LOW - 1
      IF (IEND) 180, 150, 105
!     .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
  105 DO 140 II = 1, IEND
         I = IGH - II
         IF (ORTR(I) == 0.0D0 .AND. ORTI(I) == 0.0D0) GOTO 140
         IF (HR(I,I-1) == 0.0D0 .AND. HI(I,I-1) == 0.0D0) GOTO 140
!     .......... 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
!
         DO 110 K = IP1, IGH
            ORTR(K) = HR(K,I-1)
            ORTI(K) = HI(K,I-1)
  110    CONTINUE
!
         DO 130 J = I, IGH
            SR = 0.0D0
            SI = 0.0D0
!
            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
!
            SR = FLOP(SR/NORM)
            SI = FLOP(SI/NORM)
!
            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
!
  130    CONTINUE
!
  140 CONTINUE
!*****
      IF (JOB == 3) GOTO 1001
!*****
!     .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
  150 L = LOW + 1
!
      DO 170 I = L, IGH
         LL = MIN0(I+1,IGH)
         IF (HI(I,I-1) == 0.0D0) GOTO 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
!
         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
!
         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
!*****
         IF (JOB == 0) GOTO 170
!*****
         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
!
  170 CONTINUE
!     .......... STORE ROOTS ISOLATED BY CBAL ..........
  180 DO 200 I = 1, N
         IF (I >= LOW .AND. I <= IGH) GOTO 200
         WR(I) = HR(I,I)
         WI(I) = HI(I,I)
  200 CONTINUE
!
      EN = IGH
      TR = 0.0D0
      TI = 0.0D0
      ITN = 30*N
!     .......... SEARCH FOR NEXT EIGENVALUE ..........
  220 IF (EN < LOW) GOTO 680
      ITS = 0
      ENM1 = EN - 1
!     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
!                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
  240 DO 260 LL = LOW, EN
         L = EN + LOW - LL
         IF (L == LOW) GOTO 300
!*****
         XR = FLOP(DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))&
                   + DABS(HR(L,L)) +DABS(HI(L,L)))
         YR = FLOP(XR + DABS(HR(L,L-1)))
         IF (XR == YR) GOTO 300
!*****
  260 CONTINUE
!     .......... FORM SHIFT ..........
  300 IF (L == EN) GOTO 660
      IF (ITN == 0) GOTO 1000
      IF (ITS == 10 .OR. ITS == 20) GOTO 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 == 0.0D0 .AND. XI == 0.0D0) GOTO 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 >= 0.0D0) GOTO 310
      ZZR = -ZZR
      ZZI = -ZZI
  310 CALL WDIV(XR,XI,YR+ZZR,YI+ZZI,ZZR,ZZI)
      SR = FLOP(SR - ZZR)
      SI = FLOP(SI - ZZI)
      GOTO 340
!     .......... FORM EXCEPTIONAL SHIFT ..........
  320 SR = FLOP(DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2)))
      SI = 0.0D0
!
  340 DO 360 I = LOW, EN
         HR(I,I) = FLOP(HR(I,I) - SR)
         HI(I,I) = FLOP(HI(I,I) - SI)
  360 CONTINUE
!
      TR = FLOP(TR + SR)
      TI = FLOP(TI + SI)
      ITS = ITS + 1
      ITN = ITN - 1
!     .......... REDUCE TO TRIANGLE (ROWS) ..........
      LP1 = L + 1
!
      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 +&
        (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)
!
         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
!
  500 CONTINUE
!
      SI = HI(EN,EN)
      IF (SI == 0.0D0) GOTO 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 == N) GOTO 540
      IP1 = EN + 1
!
      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
!     .......... INVERSE OPERATION (COLUMNS) ..........
  540 DO 600 J = LP1, EN
         XR = WR(J-1)
         XI = WI(J-1)
!
         DO 580 I = 1, J
            YR = HR(I,J-1)
            YI = 0.0D0
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            IF (I == J) GOTO 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
!*****
         IF (JOB == 0) GOTO 600
!*****
         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
!
  600 CONTINUE
!
      IF (SI == 0.0D0) GOTO 240
!
      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
!*****
      IF (JOB == 0) GOTO 240
!*****
      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
!
      GOTO 240
!     .......... 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
      GOTO 220
!     .......... ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
!                VECTORS OF UPPER TRIANGULAR FORM ..........
!
!*****  THE FOLLOWING SECTION CHANGED FOR OVERFLOW CONTROL
!       C. MOLER, 3/16/82
!
  680 IF (JOB /= 2) GOTO 1001
!
      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 > NORM) NORM = TR
  720 CONTINUE
      IF (N == 1 .OR. NORM == 0.0D0) GOTO 1001
!     .......... 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
!     .......... 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 /= 0.0D0 .OR. YI /= 0.0D0) GOTO 765
               YR = NORM
  760          YR = FLOP(YR/100.0D0)
               YI = FLOP(NORM + YR)
               IF (YI /= NORM) GOTO 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 == 0.0D0) GOTO 780
            IF (TR + 1.0D0/TR > TR) GOTO 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
!
  800 CONTINUE
!*****
!     .......... END BACKSUBSTITUTION ..........
      ENM1 = N - 1
!     .......... VECTORS OF ISOLATED ROOTS ..........
      DO  840 I = 1, ENM1
         IF (I >= LOW .AND. I <= IGH) GOTO 840
         IP1 = I + 1
!
         DO 820 J = IP1, N
            ZR(I,J) = HR(I,J)
            ZI(I,J) = HI(I,J)
  820    CONTINUE
!
  840 CONTINUE
!     .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
!                VECTORS OF ORIGINAL FULL MATRIX.
!                FOR J=N STEP -1 UNTIL LOW+1 DO -- ..........
      DO 880 JJ = LOW, ENM1
         J = N + LOW - JJ
         M = MIN0(J,IGH)
!
         DO 880 I = LOW, IGH
            ZZR = 0.0D0
            ZZI = 0.0D0
!
            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
!
            ZR(I,J) = ZZR
            ZI(I,J) = ZZI
  880 CONTINUE
!
      GOTO 1001
!     .......... SET ERROR -- NO CONVERGENCE TO AN
!                EIGENVALUE AFTER 30 ITERATIONS ..........
 1000 IERR = EN
 1001 RETURN
      END SUBROUTINE COMQR3
!-----------------------------------------------------------------------
      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)
!
!
!     WSVDC IS A SUBROUTINE TO REDUCE A DOUBLE-COMPLEX NXP MATRIX X BY
!     UNITARY TRANSFORMATIONS U AND V TO DIAGONAL FORM.  THE
!     DIAGONAL ELEMENTS S(I) ARE THE SINGULAR VALUES OF X.  THE
!     COLUMNS OF U ARE THE CORRESPONDING LEFT SINGULAR VECTORS,
!     AND THE COLUMNS OF V THE RIGHT SINGULAR VECTORS.
!
!     ON ENTRY
!
!         X         DOUBLE-COMPLEX(LDX,P), WHERE LDX>=N.
!                   X CONTAINS THE MATRIX WHOSE SINGULAR VALUE
!                   DECOMPOSITION IS TO BE COMPUTED.  X IS
!                   DESTROYED BY WSVDC.
!
!         LDX       INTEGER.
!                   LDX IS THE LEADING DIMENSION OF THE ARRAY X.
!
!         N         INTEGER.
!                   N IS THE NUMBER OF COLUMNS OF THE MATRIX X.
!
!         P         INTEGER.
!                   P IS THE NUMBER OF ROWS OF THE MATRIX X.
!
!         LDU       INTEGER.
!                   LDU IS THE LEADING DIMENSION OF THE ARRAY U
!                   (SEE BELOW).
!
!         LDV       INTEGER.
!                   LDV IS THE LEADING DIMENSION OF THE ARRAY V
!                   (SEE BELOW).
!
!         WORK      DOUBLE-COMPLEX(N).
!                   WORK IS A SCRATCH ARRAY.
!
!         JOB       INTEGER.
!                   JOB CONTROLS THE COMPUTATION OF THE SINGULAR
!                   VECTORS.  IT HAS THE DECIMAL EXPANSION AB
!                   WITH THE FOLLOWING MEANING
!
!     A==0    DO NOT COMPUTE THE LEFT SINGULAR
!               VECTORS.
!     A==1    RETURN THE N LEFT SINGULAR VECTORS
!               IN U.
!     A>=2    RETURNS THE FIRST MIN(N,P)
!               LEFT SINGULAR VECTORS IN U.
!     B==0    DO NOT COMPUTE THE RIGHT SINGULAR
!               VECTORS.
!     B==1    RETURN THE RIGHT SINGULAR VECTORS
!               IN V.
!
!     ON RETURN
!
!         S         DOUBLE-COMPLEX(MM), WHERE MM=MIN(N+1,P).
!                   THE FIRST MIN(N,P) ENTRIES OF S CONTAIN THE
!                   SINGULAR VALUES OF X ARRANGED IN DESCENDING
!                   ORDER OF MAGNITUDE.
!
!         E         DOUBLE-COMPLEX(P).
!                   E ORDINARILY CONTAINS ZEROS.  HOWEVER SEE THE
!                   DISCUSSION OF INFO FOR EXCEPTIONS.
!
!         U         DOUBLE-COMPLEX(LDU,K), WHERE LDU>=N.
!                   IF JOBA==1 THEN K==N,
!                   IF JOBA==2 THEN K==MIN(N,P).
!                   U CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS.
!                   U IS NOT REFERENCED IF JOBA==0.  IF N<=P
!                   OR IF JOBA>2, THEN U MAY BE IDENTIFIED WITH X
!                   IN THE SUBROUTINE CALL.
!
!         V         DOUBLE-COMPLEX(LDV,P), WHERE LDV>=P.
!                   V CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS.
!                   V IS NOT REFERENCED IF JOBB==0.  IF P<=N,
!                   THEN V MAY BE IDENTIFIED WHTH X IN THE
!                   SUBROUTINE CALL.
!
!         INFO      INTEGER.
!                   THE SINGULAR VALUES (AND THEIR CORRESPONDING
!                   SINGULAR VECTORS) S(INFO+1),S(INFO+2),...,S(M)
!                   ARE CORRECT (HERE M=MIN(N,P)).  THUS IF
!                   INFO==0, ALL THE SINGULAR VALUES AND THEIR
!                   VECTORS ARE CORRECT.  IN ANY EVENT, THE MATRIX
!                   B = CTRANS(U)*X*V IS THE BIDIAGONAL MATRIX
!                   WITH THE ELEMENTS OF S ON ITS DIAGONAL AND THE
!                   ELEMENTS OF E ON ITS SUPER-DIAGONAL (CTRANS(U)
!                   IS THE CONJUGATE-TRANSPOSE OF U).  THUS THE
!                   SINGULAR VALUES OF X AND B ARE THE SAME.
!
!     LINPACK. THIS VERSION DATED 07/03/79 .
!     G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
!
!     WSVDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
!
!     BLAS WAXPY,PYTHAG,WDOTCR,WDOTCI,WSCAL,WSWAP,WNRM2,RROTG
!     FORTRAN DABS,DIMAG,DMAX1
!     FORTRAN MAX0,MIN0,MOD,DSQRT
!
!     INTERNAL VARIABLES
!
      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
!
      DOUBLE PRECISION ZDUMR,ZDUMI
      DOUBLE PRECISION CABS1
      CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
!
!     SET THE MAXIMUM NUMBER OF ITERATIONS.
!
      MAXIT = 75
!
!     SMALL NUMBER, ROUGHLY MACHINE EPSILON, USED TO AVOID UNDERFLOW
!
      SMALL = 1.D0/2.D0**48
!
!     DETERMINE WHAT IS TO BE COMPUTED.
!
      WANTU = .FALSE.
      WANTV = .FALSE.
      JOBU = MOD(JOB,100)/10
      NCU = N
      IF (JOBU > 1) NCU = MIN0(N,P)
      IF (JOBU /= 0) WANTU = .TRUE.
      IF (MOD(JOB,10) /= 0) WANTV = .TRUE.
!
!     REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS
!     IN S AND THE SUPER-DIAGONAL ELEMENTS IN E.
!
      INFO = 0
      NCT = MIN0(N-1,P)
      NRT = MAX0(0,MIN0(P-2,N))
      LU = MAX0(NCT,NRT)
      IF (LU < 1) GOTO 190
      DO 180 L = 1, LU
         LP1 = L + 1
         IF (L > NCT) GOTO 30
!
!           COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND
!           PLACE THE L-TH DIAGONAL IN S(L).
!
            SR(L) = WNRM2(N-L+1,XR(L,L),XI(L,L),1)
            SI(L) = 0.0D0
            IF (CABS1(SR(L),SI(L)) == 0.0D0) GOTO 20
               IF (CABS1(XR(L,L),XI(L,L)) == 0.0D0) GOTO 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 < LP1) GOTO 60
         DO 50 J = LP1, P
            IF (L > NCT) GOTO 40
            IF (CABS1(SR(L),SI(L)) == 0.0D0) GOTO 40
!
!              APPLY THE TRANSFORMATION.
!
               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
!
!           PLACE THE L-TH ROW OF X INTO  E FOR THE
!           SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION.
!
            ER(J) = XR(L,J)
            EI(J) = -XI(L,J)
   50    CONTINUE
   60    CONTINUE
         IF (.NOT.WANTU .OR. L > NCT) GOTO 80
!
!           PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK
!           MULTIPLICATION.
!
            DO 70 I = L, N
               UR(I,L) = XR(I,L)
               UI(I,L) = XI(I,L)
   70       CONTINUE
   80    CONTINUE
         IF (L > NRT) GOTO 170
!
!           COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE
!           L-TH SUPER-DIAGONAL IN E(L).
!
            ER(L) = WNRM2(P-L,ER(LP1),EI(LP1),1)
            EI(L) = 0.0D0
            IF (CABS1(ER(L),EI(L)) == 0.0D0) GOTO 100
               IF (CABS1(ER(LP1),EI(LP1)) == 0.0D0) GOTO 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 > N .OR. CABS1(ER(L),EI(L)) == 0.0D0)&
               GOTO 140
!
!              APPLY THE TRANSFORMATION.
!
               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) GOTO 160
!
!              PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT
!              BACK MULTIPLICATION.
!
               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
!
!     SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M.
!
      M = MIN0(P,N+1)
      NCTP1 = NCT + 1
      NRTP1 = NRT + 1
      IF (NCT >= P) GOTO 200
         SR(NCTP1) = XR(NCTP1,NCTP1)
         SI(NCTP1) = XI(NCTP1,NCTP1)
  200 CONTINUE
      IF (N >= M) GOTO 210
         SR(M) = 0.0D0
         SI(M) = 0.0D0
  210 CONTINUE
      IF (NRTP1 >= M) GOTO 220
         ER(NRTP1) = XR(NRTP1,M)
         EI(NRTP1) = XI(NRTP1,M)
  220 CONTINUE
      ER(M) = 0.0D0
      EI(M) = 0.0D0
!
!     IF REQUIRED, GENERATE U.
!
      IF (.NOT.WANTU) GOTO 350
         IF (NCU < NCTP1) GOTO 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 < 1) GOTO 340
         DO 330 LL = 1, NCT
            L = NCT - LL + 1
            IF (CABS1(SR(L),SI(L)) == 0.0D0) GOTO 300
               LP1 = L + 1
               IF (NCU < LP1) GOTO 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 < 1) GOTO 290
               DO 280 I = 1, LM1
                  UR(I,L) = 0.0D0
                  UI(I,L) = 0.0D0
  280          CONTINUE
  290          CONTINUE
            GOTO 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
!
!     IF IT IS REQUIRED, GENERATE V.
!
      IF (.NOT.WANTV) GOTO 400
         DO 390 LL = 1, P
            L = P - LL + 1
            LP1 = L + 1
            IF (L > NRT) GOTO 370
            IF (CABS1(ER(L),EI(L)) == 0.0D0) GOTO 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
!
!     TRANSFORM S AND E SO THAT THEY ARE REAL.
!
      DO 420 I = 1, M
            TR = PYTHAG(SR(I),SI(I))
            IF (TR == 0.0D0) GOTO 405
            RR = SR(I)/TR
            RI = SI(I)/TR
            SR(I) = TR
            SI(I) = 0.0D0
            IF (I < 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
!     ...EXIT
         IF (I == M) GOTO 430
            TR = PYTHAG(ER(I),EI(I))
            IF (TR == 0.0D0) GOTO 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
!
!     MAIN ITERATION LOOP FOR THE SINGULAR VALUES.
!
      MM = M
      ITER = 0
  440 CONTINUE
!
!        QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND.
!
!     ...EXIT
         IF (M == 0) GOTO 700
!
!        IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET
!        FLAG AND RETURN.
!
         IF (ITER < MAXIT) GOTO 450
            INFO = M
!     ......EXIT
            GOTO 700
  450    CONTINUE
!
!        THIS SECTION OF THE PROGRAM INSPECTS FOR
!        NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS.  ON
!        COMPLETION THE VARIABLE KASE IS SET AS FOLLOWS.
!
!           KASE = 1     IF SR(M) AND ER(L-1) ARE NEGLIGIBLE AND L<M
!           KASE = 2     IF SR(L) IS NEGLIGIBLE AND L<M
!           KASE = 3     IF ER(L-1) IS NEGLIGIBLE, L<M, AND
!     SR(L), ..., SR(M) ARE NOT NEGLIGIBLE (QR STEP).
!           KASE = 4     IF ER(M-1) IS NEGLIGIBLE (CONVERGENCE).
!
         DO 470 LL = 1, M
            L = M - LL
!        ...EXIT
            IF (L == 0) GOTO 480
            TEST = FLOP(DABS(SR(L)) + DABS(SR(L+1)))
            ZTEST = FLOP(TEST + DABS(ER(L))/2.0D0)
            IF (SMALL*ZTEST /= SMALL*TEST) GOTO 460
               ER(L) = 0.0D0
!        ......EXIT
               GOTO 480
  460       CONTINUE
  470    CONTINUE
  480    CONTINUE
         IF (L /= M - 1) GOTO 490
            KASE = 4
         GOTO 560
  490    CONTINUE
            LP1 = L + 1
            MP1 = M + 1
            DO 510 LLS = LP1, MP1
               LS = M - LLS + LP1
!           ...EXIT
               IF (LS == L) GOTO 520
               TEST = 0.0D0
               IF (LS /= M) TEST = FLOP(TEST + DABS(ER(LS)))
               IF (LS /= L + 1) TEST = FLOP(TEST + DABS(ER(LS-1)))
               ZTEST = FLOP(TEST + DABS(SR(LS))/2.0D0)
               IF (SMALL*ZTEST /= SMALL*TEST) GOTO 500
                  SR(LS) = 0.0D0
!           ......EXIT
                  GOTO 520
  500          CONTINUE
  510       CONTINUE
  520       CONTINUE
            IF (LS /= L) GOTO 530
               KASE = 3
            GOTO 550
  530       CONTINUE
            IF (LS /= M) GOTO 540
               KASE = 1
            GOTO 550
  540       CONTINUE
               KASE = 2
               L = LS
  550       CONTINUE
  560    CONTINUE
         L = L + 1
!
!        PERFORM THE TASK INDICATED BY KASE.
!
         GOTO (570, 600, 620, 650), KASE
!
!        DEFLATE NEGLIGIBLE SR(M).
!
  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 == L) GOTO 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
         GOTO 690
!
!        SPLIT AT NEGLIGIBLE SR(L).
!
  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
         GOTO 690
!
!        PERFORM ONE QR STEP.
!
  620    CONTINUE
!
!           CALCULATE THE SHIFT.
!
            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 == 0.0D0 .AND. C == 0.0D0) GOTO 630
               SHIFT = FLOP(DSQRT(B**2+C))
               IF (B < 0.0D0) SHIFT = -SHIFT
               SHIFT = FLOP(C/(B + SHIFT))
  630       CONTINUE
            F = FLOP((SL + SM)*(SL - SM) - SHIFT)
            G = FLOP(SL*EL)
!
!           CHASE ZEROS.
!
            MM1 = M - 1
            DO 640 K = L, MM1
               CALL RROTG(F,G,CS,SN)
               IF (K /= 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 < N)&
                  CALL RROT(N,UR(1,K),1,UR(1,K+1),1,CS,SN)
               IF (WANTU .AND. K < N)&
                  CALL RROT(N,UI(1,K),1,UI(1,K+1),1,CS,SN)
  640       CONTINUE
            ER(M-1) = F
            ITER = ITER + 1
         GOTO 690
!
!        CONVERGENCE
!
  650    CONTINUE
!
!           MAKE THE SINGULAR VALUE  POSITIVE
!
            IF (SR(L) >= 0.0D0) GOTO 660
               SR(L) = -SR(L)
             IF (WANTV) CALL WRSCAL(P,-1.0D0,VR(1,L),VI(1,L),1)
  660       CONTINUE
!
!           ORDER THE SINGULAR VALUE.
!
  670       IF (L == MM) GOTO 680
!           ...EXIT
               IF (SR(L) >= SR(L+1)) GOTO 680
               TR = SR(L)
               SR(L) = SR(L+1)
               SR(L+1) = TR
               IF (WANTV .AND. L < P)&
                  CALL WSWAP(P,VR(1,L),VI(1,L),1,VR(1,L+1),VI(1,L+1),1)
               IF (WANTU .AND. L < N)&
                  CALL WSWAP(N,UR(1,L),UI(1,L),1,UR(1,L+1),UI(1,L+1),1)
               L = L + 1
            GOTO 670
  680       CONTINUE
            ITER = 0
            M = M - 1
  690    CONTINUE
      GOTO 440
  700 CONTINUE
      RETURN
      END SUBROUTINE WSVDC

      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)
!
!     WQRDC USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR
!     FACTORIZATION OF AN N BY P MATRIX X.  COLUMN PIVOTING
!     BASED ON THE 2-NORMS OF THE REDUCED COLUMNS MAY BE
!     PERFORMED AT THE USERS OPTION.
!
!     ON ENTRY
!
!        X       DOUBLE-COMPLEX(LDX,P), WHERE LDX >= N.
!                X CONTAINS THE MATRIX WHOSE DECOMPOSITION IS TO BE
!                COMPUTED.
!
!        LDX     INTEGER.
!                LDX IS THE LEADING DIMENSION OF THE ARRAY X.
!
!        N       INTEGER.
!                N IS THE NUMBER OF ROWS OF THE MATRIX X.
!
!        P       INTEGER.
!                P IS THE NUMBER OF COLUMNS OF THE MATRIX X.
!
!        JPVT    INTEGER(P).
!                JPVT CONTAINS INTEGERS THAT CONTROL THE SELECTION
!                OF THE PIVOT COLUMNS.  THE K-TH COLUMN X(K) OF X
!                IS PLACED IN ONE OF THREE CLASSES ACCORDING TO THE
!                VALUE OF JPVT(K).
!
!                   IF JPVT(K) > 0, THEN X(K) IS AN INITIAL
!                   COLUMN.
!
!                   IF JPVT(K) == 0, THEN X(K) IS A FREE COLUMN.
!
!                   IF JPVT(K) < 0, THEN X(K) IS A FINAL COLUMN.
!
!                BEFORE THE DECOMPOSITION IS COMPUTED, INITIAL COLUMNS
!                ARE MOVED TO THE BEGINNING OF THE ARRAY X AND FINAL
!                COLUMNS TO THE END.  BOTH INITIAL AND FINAL COLUMNS
!                ARE FROZEN IN PLACE DURING THE COMPUTATION AND ONLY
!                FREE COLUMNS ARE MOVED.  AT THE K-TH STAGE OF THE
!                REDUCTION, IF X(K) IS OCCUPIED BY A FREE COLUMN
!                IT IS INTERCHANGED WITH THE FREE COLUMN OF LARGEST
!                REDUCED NORM.  JPVT IS NOT REFERENCED IF
!                JOB == 0.
!
!        WORK    DOUBLE-COMPLEX(P).
!                WORK IS A WORK ARRAY.  WORK IS NOT REFERENCED IF
!                JOB == 0.
!
!        JOB     INTEGER.
!                JOB IS AN INTEGER THAT INITIATES COLUMN PIVOTING.
!                IF JOB == 0, NO PIVOTING IS DONE.
!                IF JOB /= 0, PIVOTING IS DONE.
!
!     ON RETURN
!
!        X       X CONTAINS IN ITS UPPER TRIANGLE THE UPPER
!                TRIANGULAR MATRIX R OF THE QR FACTORIZATION.
!                BELOW ITS DIAGONAL X CONTAINS INFORMATION FROM
!                WHICH THE UNITARY PART OF THE DECOMPOSITION
!                CAN BE RECOVERED.  NOTE THAT IF PIVOTING HAS
!                BEEN REQUESTED, THE DECOMPOSITION IS NOT THAT
!                OF THE ORIGINAL MATRIX X BUT THAT OF X
!                WITH ITS COLUMNS PERMUTED AS DESCRIBED BY JPVT.
!
!        QRAUX   DOUBLE-COMPLEX(P).
!                QRAUX CONTAINS FURTHER INFORMATION REQUIRED TO RECOVER
!                THE UNITARY PART OF THE DECOMPOSITION.
!
!        JPVT    JPVT(K) CONTAINS THE INDEX OF THE COLUMN OF THE
!                ORIGINAL MATRIX THAT HAS BEEN INTERCHANGED INTO
!                THE K-TH COLUMN, IF PIVOTING WAS REQUESTED.
!
!     LINPACK. THIS VERSION DATED 07/03/79 .
!     G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
!
!     WQRDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
!
!     BLAS WAXPY,PYTHAG,WDOTCR,WDOTCI,WSCAL,WSWAP,WNRM2
!     FORTRAN DABS,DIMAG,DMAX1,MIN0
!
!     INTERNAL VARIABLES
!
      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
!
      DOUBLE PRECISION ZDUMR,ZDUMI
      DOUBLE PRECISION CABS1
      CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
!
      PL = 1
      PU = 0
      IF (JOB == 0) GOTO 60
!
!        PIVOTING HAS BEEN REQUESTED.  REARRANGE THE COLUMNS
!        ACCORDING TO JPVT.
!
         DO 20 J = 1, P
            SWAPJ = JPVT(J) > 0
            NEGJ = JPVT(J) < 0
            JPVT(J) = J
            IF (NEGJ) JPVT(J) = -J
            IF (.NOT.SWAPJ) GOTO 10
               IF (J /= 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) >= 0) GOTO 40
               JPVT(J) = -JPVT(J)
               IF (J == PU) GOTO 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
!
!     COMPUTE THE NORMS OF THE FREE COLUMNS.
!
      IF (PU < PL) GOTO 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
!
!     PERFORM THE HOUSEHOLDER REDUCTION OF X.
!
      LUP = MIN0(N,P)
      DO 210 L = 1, LUP
         IF (L < PL .OR. L >= PU) GOTO 120
!
!           LOCATE THE COLUMN OF LARGEST NORM AND BRING IT
!           INTO THE PIVOT POSITION.
!
            MAXNRM = 0.0D0
            MAXJ = L
            DO 100 J = L, PU
               IF (QRAUXR(J) <= MAXNRM) GOTO 90
                  MAXNRM = QRAUXR(J)
                  MAXJ = J
   90          CONTINUE
  100       CONTINUE
            IF (MAXJ == L) GOTO 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 == N) GOTO 200
!
!           COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L.
!
            NRMXLR = WNRM2(N-L+1,XR(L,L),XI(L,L),1)
            NRMXLI = 0.0D0
            IF (CABS1(NRMXLR,NRMXLI) == 0.0D0) GOTO 190
               IF (CABS1(XR(L,L),XI(L,L)) == 0.0D0) GOTO 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))
!
!              APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS,
!              UPDATING THE NORMS.
!
               LP1 = L + 1
               IF (P < LP1) GOTO 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 < PL .OR. J > PU) GOTO 160
                  IF (CABS1(QRAUXR(J),QRAUXI(J)) == 0.0D0)&
                     GOTO 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 == 1.0D0) GOTO 140
                     QRAUXR(J) = QRAUXR(J)*DSQRT(TR)
                     QRAUXI(J) = QRAUXI(J)*DSQRT(TR)
                     GOTO 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
!
!              SAVE THE TRANSFORMATION.
!
               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 WQRDC

!-----------------------------------------------------------------------
      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)
!
!     WQRSL APPLIES THE OUTPUT OF WQRDC TO COMPUTE COORDINATE
!     TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS.
!     FOR K <= MIN(N,P), LET XK BE THE MATRIX
!
!            XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K)))
!
!     FORMED FROM COLUMNNS JPVT(1), ... ,JPVT(K) OF THE ORIGINAL
!     N X P MATRIX X THAT WAS INPUT TO WQRDC (IF NO PIVOTING WAS
!     DONE, XK CONSISTS OF THE FIRST K COLUMNS OF X IN THEIR
!     ORIGINAL ORDER).  WQRDC PRODUCES A FACTORED UNITARY MATRIX Q
!     AND AN UPPER TRIANGULAR MATRIX R SUCH THAT
!
!              XK = Q * (R)
!    (0)
!
!     THIS INFORMATION IS CONTAINED IN CODED FORM IN THE ARRAYS
!     X AND QRAUX.
!
!     ON ENTRY
!
!        X      DOUBLE-COMPLEX(LDX,P).
!               X CONTAINS THE OUTPUT OF WQRDC.
!
!        LDX    INTEGER.
!               LDX IS THE LEADING DIMENSION OF THE ARRAY X.
!
!        N      INTEGER.
!               N IS THE NUMBER OF ROWS OF THE MATRIX XK.  IT MUST
!               HAVE THE SAME VALUE AS N IN WQRDC.
!
!        K      INTEGER.
!               K IS THE NUMBER OF COLUMNS OF THE MATRIX XK.  K
!               MUST NNOT BE GREATER THAN MIN(N,P), WHERE P IS THE
!               SAME AS IN THE CALLING SEQUENCE TO WQRDC.
!
!        QRAUX  DOUBLE-COMPLEX(P).
!               QRAUX CONTAINS THE AUXILIARY OUTPUT FROM WQRDC.
!
!        Y      DOUBLE-COMPLEX(N)
!               Y CONTAINS AN N-VECTOR THAT IS TO BE MANIPULATED
!               BY WQRSL.
!
!        JOB    INTEGER.
!               JOB SPECIFIES WHAT IS TO BE COMPUTED.  JOB HAS
!               THE DECIMAL EXPANSION ABCDE, WITH THE FOLLOWING
!               MEANING.
!
! IF A/=0, COMPUTE QY.
! IF B,C,D, OR E /= 0, COMPUTE QTY.
! IF C/=0, COMPUTE B.
! IF D/=0, COMPUTE RSD.
! IF E/=0, COMPUTE XB.
!
!               NOTE THAT A REQUEST TO COMPUTE B, RSD, OR XB
!               AUTOMATICALLY TRIGGERS THE COMPUTATION OF QTY, FOR
!               WHICH AN ARRAY MUST BE PROVIDED IN THE CALLING
!               SEQUENCE.
!
!     ON RETURN
!
!        QY     DOUBLE-COMPLEX(N).
!               QY CONNTAINS Q*Y, IF ITS COMPUTATION HAS BEEN
!               REQUESTED.
!
!        QTY    DOUBLE-COMPLEX(N).
!               QTY CONTAINS CTRANS(Q)*Y, IF ITS COMPUTATION HAS
!               BEEN REQUESTED.  HERE CTRANS(Q) IS THE CONJUGATE
!               TRANSPOSE OF THE MATRIX Q.
!
!        B      DOUBLE-COMPLEX(K)
!               B CONTAINS THE SOLUTION OF THE LEAST SQUARES PROBLEM
!
! MINIMIZE NORM2(Y - XK*B),
!
!               IF ITS COMPUTATION HAS BEEN REQUESTED.  (NOTE THAT
!               IF PIVOTING WAS REQUESTED IN WQRDC, THE J-TH
!               COMPONENT OF B WILL BE ASSOCIATED WITH COLUMN JPVT(J)
!               OF THE ORIGINAL MATRIX X THAT WAS INPUT INTO WQRDC.)
!
!        RSD    DOUBLE-COMPLEX(N).
!               RSD CONTAINS THE LEAST SQUARES RESIDUAL Y - XK*B,
!               IF ITS COMPUTATION HAS BEEN REQUESTED.  RSD IS
!               ALSO THE ORTHOGONAL PROJECTION OF Y ONTO THE
!               ORTHOGONAL COMPLEMENT OF THE COLUMN SPACE OF XK.
!
!        XB     DOUBLE-COMPLEX(N).
!               XB CONTAINS THE LEAST SQUARES APPROXIMATION XK*B,
!               IF ITS COMPUTATION HAS BEEN REQUESTED.  XB IS ALSO
!               THE ORTHOGONAL PROJECTION OF Y ONTO THE COLUMN SPACE
!               OF X.
!
!        INFO   INTEGER.
!               INFO IS ZERO UNLESS THE COMPUTATION OF B HAS
!               BEEN REQUESTED AND R IS EXACTLY SINGULAR.  IN
!               THIS CASE, INFO IS THE INDEX OF THE FIRST ZERO
!               DIAGONAL ELEMENT OF R AND B IS LEFT UNALTERED.
!
!     THE PARAMETERS QY, QTY, B, RSD, AND XB ARE NOT REFERENCED
!     IF THEIR COMPUTATION IS NOT REQUESTED AND IN THIS CASE
!     CAN BE REPLACED BY DUMMY VARIABLES IN THE CALLING PROGRAM.
!     TO SAVE STORAGE, THE USER MAY IN SOME CASES USE THE SAME
!     ARRAY FOR DIFFERENT PARAMETERS IN THE CALLING SEQUENCE.  A
!     FREQUENTLY OCCURING EXAMPLE IS WHEN ONE WISHES TO COMPUTE
!     ANY OF B, RSD, OR XB AND DOES NOT NEED Y OR QTY.  IN THIS
!     CASE ONE MAY IDENTIFY Y, QTY, AND ONE OF B, RSD, OR XB, WHILE
!     PROVIDING SEPARATE ARRAYS FOR ANYTHING ELSE THAT IS TO BE
!     COMPUTED.  THUS THE CALLING SEQUENCE
!
!          CALL WQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO)
!
!     WILL RESULT IN THE COMPUTATION OF B AND RSD, WITH RSD
!     OVERWRITING Y.  MORE GENERALLY, EACH ITEM IN THE FOLLOWING
!     LIST CONTAINS GROUPS OF PERMISSIBLE IDENTIFICATIONS FOR
!     A SINGLE CALLINNG SEQUENCE.
!
!          1. (Y,QTY,B) (RSD) (XB) (QY)
!
!          2. (Y,QTY,RSD) (B) (XB) (QY)
!
!          3. (Y,QTY,XB) (B) (RSD) (QY)
!
!          4. (Y,QY) (QTY,B) (RSD) (XB)
!
!          5. (Y,QY) (QTY,RSD) (B) (XB)
!
!          6. (Y,QY) (QTY,XB) (B) (RSD)
!
!     IN ANY GROUP THE VALUE RETURNED IN THE ARRAY ALLOCATED TO
!     THE GROUP CORRESPONDS TO THE LAST MEMBER OF THE GROUP.
!
!     LINPACK. THIS VERSION DATED 07/03/79 .
!     G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
!
!     WQRSL USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
!
!     BLAS WAXPY,WCOPY,WDOTCR,WDOTCI
!     FORTRAN DABS,DIMAG,MIN0,MOD
!
!     INTERNAL VARIABLES
!
      INTEGER I,J,JJ,JU,KP1
      DOUBLE PRECISION WDOTCR,WDOTCI,TR,TI,TEMPR,TEMPI
      LOGICAL CB,CQY,CQTY,CR,CXB
!
      DOUBLE PRECISION ZDUMR,ZDUMI
      DOUBLE PRECISION CABS1
      CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
!
!     SET INFO FLAG.
!
      INFO = 0
!
!     DETERMINE WHAT IS TO BE COMPUTED.
!
      CQY = JOB/10000 /= 0
      CQTY = MOD(JOB,10000) /= 0
      CB = MOD(JOB,1000)/100 /= 0
      CR = MOD(JOB,100)/10 /= 0
      CXB = MOD(JOB,10) /= 0
      JU = MIN0(K,N-1)
!
!     SPECIAL ACTION WHEN N=1.
!
      IF (JU /= 0) GOTO 80
         IF (.NOT.CQY) GOTO 10
            QYR(1) = YR(1)
            QYI(1) = YI(1)
   10    CONTINUE
         IF (.NOT.CQTY) GOTO 20
            QTYR(1) = YR(1)
            QTYI(1) = YI(1)
   20    CONTINUE
         IF (.NOT.CXB) GOTO 30
            XBR(1) = YR(1)
            XBI(1) = YI(1)
   30    CONTINUE
         IF (.NOT.CB) GOTO 60
            IF (CABS1(XR(1,1),XI(1,1)) /= 0.0D0) GOTO 40
               INFO = 1
            GOTO 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) GOTO 70
            RSDR(1) = 0.0D0
            RSDI(1) = 0.0D0
   70    CONTINUE
      GOTO 290
   80 CONTINUE
!
!        SET UP TO COMPUTE QY OR QTY.
!
         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) GOTO 110
!
!           COMPUTE QY.
!
            DO 100 JJ = 1, JU
               J = JU - JJ + 1
               IF (CABS1(QRAUXR(J),QRAUXI(J)) == 0.0D0)&
                  GOTO 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) GOTO 140
!
!           COMPUTE CTRANS(Q)*Y.
!
            DO 130 J = 1, JU
               IF (CABS1(QRAUXR(J),QRAUXI(J)) == 0.0D0)&
                  GOTO 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
!
!        SET UP TO COMPUTE B, RSD, OR XB.
!
         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 < N)&
            CALL WCOPY(N-K,QTYR(KP1),QTYI(KP1),1,RSDR(KP1),RSDI(KP1),1)
         IF (.NOT.CXB .OR. KP1 > N) GOTO 160
            DO 150 I = KP1, N
               XBR(I) = 0.0D0
               XBI(I) = 0.0D0
  150       CONTINUE
  160    CONTINUE
         IF (.NOT.CR) GOTO 180
            DO 170 I = 1, K
               RSDR(I) = 0.0D0
               RSDI(I) = 0.0D0
  170       CONTINUE
  180    CONTINUE
         IF (.NOT.CB) GOTO 230
!
!           COMPUTE B.
!
            DO 210 JJ = 1, K
               J = K - JJ + 1
               IF (CABS1(XR(J,J),XI(J,J)) /= 0.0D0) GOTO 190
                  INFO = J
!                 ......EXIT
!           ......EXIT
                  GOTO 220
  190          CONTINUE
               CALL WDIV(BR(J),BI(J),XR(J,J),XI(J,J),BR(J),BI(J))
               IF (J == 1) GOTO 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) GOTO 280
!
!           COMPUTE RSD OR XB AS REQUIRED.
!
            DO 270 JJ = 1, JU
               J = JU - JJ + 1
               IF (CABS1(QRAUXR(J),QRAUXI(J)) == 0.0D0)&
                  GOTO 260
                  TEMPR = XR(J,J)
                  TEMPI = XI(J,J)
                  XR(J,J) = QRAUXR(J)
                  XI(J,J) = QRAUXI(J)
                  IF (.NOT.CR) GOTO 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) GOTO 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 WQRSL

!-----------------------------------------------------------------------
      SUBROUTINE MAGIC(A,LDA,N)
!
!     ALGORITHMS FOR MAGIC SQUARES TAKEN FROM
!        MATHEMATICAL RECREATIONS AND ESSAYS, 12TH ED.,
!        BY W. W. ROUSE BALL AND H. S. M. COXETER
!
      DOUBLE PRECISION A(LDA,N),T
!
      IF (MOD(N,4) == 0) GOTO 100
      IF (MOD(N,2) == 0) M = N/2
      IF (MOD(N,2) /= 0) M = N
!
!     ODD ORDER OR UPPER CORNER OF EVEN ORDER
!
      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<1) I1 = M
         IF(J1>M) J1 = 1
         IF(IDINT(A(I1,J1))==0) GOTO 30
            I1 = I+1
            J1 = J
   30    I = I1
         J = J1
   40 CONTINUE
      IF (MOD(N,2) /= 0) RETURN
!
!     REST OF EVEN ORDER
!
      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==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>N) RETURN
      DO 80 J = M1, N
         CALL RSWAP(M,A(1,J),1,A(M+1,J),1)
   80 CONTINUE
      RETURN
!
!     DOUBLE EVEN ORDER
!
  100 K = 1
      DO 120 I = 1, N
         DO 110 J = 1, N
            A(I,J) = K
            IF (MOD(I,4)/2 == MOD(J,4)/2) A(I,J) = N*N+1 - K
            K = K+1
  110    CONTINUE
  120 CONTINUE
      RETURN
      END SUBROUTINE MAGIC

!-----------------------------------------------------------------------
      SUBROUTINE BASE(X,B,EPS,S,N)
      DOUBLE PRECISION X,B,EPS,S(1),T
!
!     STORE BASE B REPRESENTATION OF X IN S(1:N)
!
      INTEGER PLUS,MINUS,DOT,ZERO,COMMA
      DATA PLUS/41/,MINUS/42/,DOT/47/,ZERO/0/,COMMA/48/
      save plus, minus, dot, zero, comma
      L = 1
      IF (X >= 0.0D0) S(L) = PLUS
      IF (X < 0.0D0) S(L) = MINUS
      S(L+1) = ZERO
      S(L+2) = DOT
      X = DABS(X)
      IF (X /= 0.0D0) THEN
         K = DLOG(X)/DLOG(B)
      ELSE
         K = 0
      ENDIF
      IF (X > 1.0D0) K = K + 1
      X = X/B**K
      IF (B*X >= B) K = K + 1
      IF (B*X >= B) X = X/B
      IF (EPS /= 0.0D0)THEN
         M = (-1)*DLOG(EPS)/DLOG(B) + 4
      ELSE
         M = 54
      ENDIF
      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 >= 0) S(M+2) = PLUS
      IF (K < 0) S(M+2) = MINUS
      T = DABS(DFLOAT(K))
      N = M + 3
      IF (T >= 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 >= M+3) GOTO 20
      RETURN
      END SUBROUTINE BASE

      DOUBLE PRECISION FUNCTION URAND(IY)
      INTEGER IY
!
!      URAND IS A UNIFORM RANDOM NUMBER GENERATOR BASED  ON  THEORY  AND
!  SUGGESTIONS  GIVEN  IN  D.E. KNUTH (1969),  VOL  2.   THE INTEGER  IY
!  SHOULD BE INITIALIZED TO AN ARBITRARY INTEGER PRIOR TO THE FIRST CALL
!  TO URAND.  THE CALLING PROGRAM SHOULD  NOT  ALTER  THE  VALUE  OF  IY
!  BETWEEN  SUBSEQUENT CALLS TO URAND.  VALUES OF URAND WILL BE RETURNED
!  IN THE INTERVAL (0,1).
!
      INTEGER IA,IC,ITWO,M2,M,MIC
      DOUBLE PRECISION HALFM,S
      DOUBLE PRECISION DATAN,DSQRT
      DATA M2/0/,ITWO/2/
      save m2, itwo
      IF (M2 /= 0) GOTO 20
!
!  IF FIRST ENTRY, COMPUTE MACHINE INTEGER WORD LENGTH
!
      M = 1
   10 M2 = M
      M = ITWO*M2
      IF (M > M2) GOTO 10
      HALFM = M2
!
!  COMPUTE MULTIPLIER AND INCREMENT FOR LINEAR CONGRUENTIAL METHOD
!
      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
!
!  S IS THE SCALE FACTOR FOR CONVERTING TO FLOATING POINT
!
      S = 0.5D0/HALFM
!
!  COMPUTE NEXT RANDOM NUMBER
!
   20 IY = IY*IA
!
!  THE FOLLOWING STATEMENT IS FOR COMPUTERS WHICH DO NOT ALLOW
!  INTEGER OVERFLOW ON ADDITION
!
      IF (IY > MIC) IY = (IY - M2) - M2
!
      IY = IY + IC
!
!  THE FOLLOWING STATEMENT IS FOR COMPUTERS WHERE THE
!  WORD LENGTH FOR ADDITION IS GREATER THAN FOR MULTIPLICATION
!
      IF (IY/2 > M2) IY = (IY - M2) - M2
!
!  THE FOLLOWING STATEMENT IS FOR COMPUTERS WHERE INTEGER
!  OVERFLOW AFFECTS THE SIGN BIT
!
      IF (IY < 0) IY = (IY + M2) + M2
      URAND = DFLOAT(IY)*S
      RETURN
      END FUNCTION URAND

!-----------------------------------------------------------------------
      SUBROUTINE WMUL(AR,AI,BR,BI,CR,CI)
      DOUBLE PRECISION AR,AI,BR,BI,CR,CI,T,FLOP
!     C = A*B
      T = AR*BI + AI*BR
      IF (T /= 0.0D0) T = FLOP(T)
      CR = FLOP(AR*BR - AI*BI)
      CI = T
      RETURN
      END SUBROUTINE WMUL

!-----------------------------------------------------------------------
      SUBROUTINE WDIV(AR,AI,BR,BI,CR,CI)
      DOUBLE PRECISION AR,AI,BR,BI,CR,CI
!     C = A/B
      DOUBLE PRECISION S,D,ARS,AIS,BRS,BIS,FLOP
      S = DABS(BR) + DABS(BI)
      IF (S == 0.0D0) CALL ERROR(27)
      IF (S == 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 /= 0.0D0) CI = FLOP(CI)
      RETURN
      END SUBROUTINE WDIV

!-----------------------------------------------------------------------
      SUBROUTINE WSIGN(XR,XI,YR,YI,ZR,ZI)
      DOUBLE PRECISION XR,XI,YR,YI,ZR,ZI,PYTHAG,T
!     IF Y /= 0, Z = X*Y/ABS(Y)
!     IF Y == 0, Z = X
      T = PYTHAG(YR,YI)
      ZR = XR
      ZI = XI
      IF (T /= 0.0D0) CALL WMUL(YR/T,YI/T,ZR,ZI,ZR,ZI)
      RETURN
      END SUBROUTINE WSIGN

!-----------------------------------------------------------------------
      SUBROUTINE WSQRT(XR,XI,YR,YI)
      DOUBLE PRECISION XR,XI,YR,YI,S,TR,TI,PYTHAG,FLOP
!     Y = SQRT(X) WITH YR >= 0.0 AND SIGN(YI) == SIGN(XI)
!
      TR = XR
      TI = XI
      S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
      IF (TR >= 0.0D0) YR = FLOP(S)
      IF (TI < 0.0D0) S = -S
      IF (TR <= 0.0D0) YI = FLOP(S)
      IF (TR < 0.0D0) YR = FLOP(0.5D0*(TI/YI))
      IF (TR > 0.0D0) YI = FLOP(0.5D0*(TI/YR))
      RETURN
      END SUBROUTINE WSQRT

!-----------------------------------------------------------------------
      SUBROUTINE WLOG(XR,XI,YR,YI)
      DOUBLE PRECISION XR,XI,YR,YI,T,R,PYTHAG
!     Y = LOG(X)
      R = PYTHAG(XR,XI)
      IF (R == 0.0D0) CALL ERROR(32)
      IF (R == 0.0D0) RETURN
      T = DATAN2(XI,XR)
      IF (XI==0.0D0 .AND. XR<0.0D0) T = DABS(T)
      YR = DLOG(R)
      YI = T
      RETURN
      END SUBROUTINE WLOG

!-----------------------------------------------------------------------
      SUBROUTINE WATAN(XR,XI,YR,YI)
!     Y = ATAN(X) = (I/2)*LOG((I+X)/(I-X))
      DOUBLE PRECISION XR,XI,YR,YI,TR,TI
      IF (XI /= 0.0D0) GOTO 10
         YR = DATAN2(XR,1.0D0)
         YI = 0.0D0
         RETURN
   10 IF (XR/=0.0D0 .OR. DABS(XI)/=1.0D0) GOTO 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 SUBROUTINE WATAN

!-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION WNRM2(N,XR,XI,INCX)
      DOUBLE PRECISION XR(1),XI(1),PYTHAG,S
!     NORM2(X)
      S = 0.0D0
      IF (N <= 0) GOTO 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 FUNCTION WNRM2

!-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION WASUM(N,XR,XI,INCX)
      DOUBLE PRECISION XR(1),XI(1),S,FLOP
!     NORM1(X)
      S = 0.0D0
      IF (N <= 0) GOTO 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 FUNCTION WASUM

!-----------------------------------------------------------------------
      INTEGER FUNCTION IWAMAX(N,XR,XI,INCX)
      DOUBLE PRECISION XR(1),XI(1),S,P
!     INDEX OF NORMINF(X)
      K = 0
      IF (N <= 0) GOTO 20
      K = 1
      S = 0.0D0
      IX = 1
      DO 10 I = 1, N
         P = DABS(XR(IX)) + DABS(XI(IX))
         IF (P > S) K = I
         IF (P > S) S = P
         IX = IX + INCX
   10 CONTINUE
   20 IWAMAX = K
      RETURN
      END FUNCTION IWAMAX

!-----------------------------------------------------------------------
      SUBROUTINE WRSCAL(N,S,XR,XI,INCX)
      DOUBLE PRECISION S,XR(1),XI(1),FLOP
      IF (N <= 0) RETURN
      IX = 1
      DO 10 I = 1, N
         XR(IX) = FLOP(S*XR(IX))
         IF (XI(IX) /= 0.0D0) XI(IX) = FLOP(S*XI(IX))
         IX = IX + INCX
   10 CONTINUE
      RETURN
      END SUBROUTINE WRSCAL

      SUBROUTINE WSCAL(N,SR,SI,XR,XI,INCX)
      DOUBLE PRECISION SR,SI,XR(1),XI(1)
      IF (N <= 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 WSCAL

!-----------------------------------------------------------------------
      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 <= 0) RETURN
      IF (SR == 0.0D0 .AND. SI == 0.0D0) RETURN
      IX = 1
      IY = 1
      IF (INCX<0) IX = (-N+1)*INCX + 1
      IF (INCY<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) /= 0.0D0) YI(IY) = FLOP(YI(IY))
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
      RETURN
      END SUBROUTINE WAXPY

!-----------------------------------------------------------------------
      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 <= 0) GOTO 20
      IX = 1
      IY = 1
      IF (INCX<0) IX = (-N+1)*INCX + 1
      IF (INCY<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 FUNCTION WDOTUR

!-----------------------------------------------------------------------
      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 <= 0) GOTO 20
      IX = 1
      IY = 1
      IF (INCX<0) IX = (-N+1)*INCX + 1
      IF (INCY<0) IY = (-N+1)*INCY + 1
      DO 10 I = 1, N
         S = S + XR(IX)*YI(IY) + XI(IX)*YR(IY)
         IF (S /= 0.0D0) S = FLOP(S)
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
   20 WDOTUI = S
      RETURN
      END FUNCTION WDOTUI

!-----------------------------------------------------------------------
      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 <= 0) GOTO 20
      IX = 1
      IY = 1
      IF (INCX<0) IX = (-N+1)*INCX + 1
      IF (INCY<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 FUNCTION WDOTCR

!-----------------------------------------------------------------------
      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 <= 0) GOTO 20
      IX = 1
      IY = 1
      IF (INCX<0) IX = (-N+1)*INCX + 1
      IF (INCY<0) IY = (-N+1)*INCY + 1
      DO 10 I = 1, N
         S = S + XR(IX)*YI(IY) - XI(IX)*YR(IY)
         IF (S /= 0.0D0) S = FLOP(S)
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
   20 WDOTCI = S
      RETURN
      END FUNCTION WDOTCI

!-----------------------------------------------------------------------
      SUBROUTINE WCOPY(N,XR,XI,INCX,YR,YI,INCY)
      DOUBLE PRECISION XR(1),XI(1),YR(1),YI(1)
      IF (N <= 0) RETURN
      IX = 1
      IY = 1
      IF (INCX<0) IX = (-N+1)*INCX + 1
      IF (INCY<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 WCOPY

!-----------------------------------------------------------------------
      SUBROUTINE WSET(N,XR,XI,YR,YI,INCY)
      INTEGER N,INCY
      DOUBLE PRECISION XR,XI,YR(1),YI(1)
      IY = 1
      IF (N <= 0 ) RETURN
      DO 10 I = 1,N
         YR(IY) = XR
         YI(IY) = XI
         IY = IY + INCY
   10 CONTINUE
      RETURN
      END SUBROUTINE WSET

!-----------------------------------------------------------------------
      SUBROUTINE WSWAP(N,XR,XI,INCX,YR,YI,INCY)
      DOUBLE PRECISION XR(1),XI(1),YR(1),YI(1),T
      IF (N <= 0) RETURN
      IX = 1
      IY = 1
      IF (INCX<0) IX = (-N+1)*INCX + 1
      IF (INCY<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 WSWAP

!-----------------------------------------------------------------------
      SUBROUTINE RSET(N,DX,DY,INCY)
!
!     COPIES A SCALAR, X, TO A SCALAR, Y.
      DOUBLE PRECISION DX,DY(1)
!
      IF (N<=0) RETURN
      IY = 1
      IF (INCY<0) IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DY(IY) = DX
        IY = IY + INCY
   10 CONTINUE
      RETURN
      END SUBROUTINE RSET

!-----------------------------------------------------------------------
      SUBROUTINE RSWAP(N,X,INCX,Y,INCY)
      DOUBLE PRECISION X(1),Y(1),T
      IF (N <= 0) RETURN
      IX = 1
      IY = 1
      IF (INCX<0) IX = (-N+1)*INCX+1
      IF (INCY<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 RSWAP

!-----------------------------------------------------------------------
      SUBROUTINE RROT(N,DX,INCX,DY,INCY,C,S)
!
!     APPLIES A PLANE ROTATION.
      DOUBLE PRECISION DX(1),DY(1),DTEMP,C,S,FLOP
      INTEGER I,INCX,INCY,IX,IY,N
!
      IF (N<=0) RETURN
      IX = 1
      IY = 1
      IF (INCX<0) IX = (-N+1)*INCX + 1
      IF (INCY<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 RROT

!-----------------------------------------------------------------------
      SUBROUTINE RROTG(DA,DB,C,S)
!
!     CONSTRUCT GIVENS PLANE ROTATION.
!
      DOUBLE PRECISION DA,DB,C,S,RHO,PYTHAG,FLOP,R,Z
!
      RHO = DB
      IF ( DABS(DA) > DABS(DB) ) RHO = DA
      C = 1.0D0
      S = 0.0D0
      Z = 1.0D0
      R = FLOP(DSIGN(PYTHAG(DA,DB),RHO))
      IF (R /= 0.0D0) C = FLOP(DA/R)
      IF (R /= 0.0D0) S = FLOP(DB/R)
      IF ( DABS(DA) > DABS(DB) ) Z = S
      IF ( DABS(DB) >= DABS(DA) .AND. C /= 0.0D0 ) Z = FLOP(1.0D0/C)
      DA = R
      DB = Z
      RETURN
      END SUBROUTINE RROTG

!-----------------------------------------------------------------------
      LOGICAL FUNCTION EQID(X,Y)
!     CHECK FOR EQUALITY OF TWO NAMES
      INTEGER X(4),Y(4)
      EQID = .TRUE.
      DO 10 I = 1, 4
   10 EQID = EQID .AND. (X(I)==Y(I))
      RETURN
      END FUNCTION EQID

!-----------------------------------------------------------------------
      SUBROUTINE PUTID(X,Y)
!     STORE A NAME
      INTEGER X(4),Y(4)
      DO 10 I = 1, 4
   10 X(I) = Y(I)
      RETURN
      END SUBROUTINE PUTID

!-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION ROUND(X)
      DOUBLE PRECISION X,Y,Z,E,H
      DATA H/1.0D9/
      save H
      Z = DABS(X)
      Y = Z + 1.0D0
      IF (Y == Z) GOTO 40
      Y = 0.0D0
      E = H
   10 IF (E >= Z) GOTO 20
         E = 2.0D0*E
         GOTO 10
   20 IF (E <= H) GOTO 30
         IF (E <= Z) Y = Y + E
         IF (E <= Z) Z = Z - E
         E = E/2.0D0
         GOTO 20
   30 Z = IDINT(Z + 0.5D0)
      Y = Y + Z
      IF (X < 0.0D0) Y = -Y
      ROUND = Y
      RETURN
   40 ROUND = X
      RETURN
      END FUNCTION ROUND

!-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION ML_DFLOAT(I)
!
!   THIS IS THE AMIGA FUNCTION WHICH CONVERTS INTEGERS TO DOUBLE FLOATS
!
      IMPLICIT NONE
      INTEGER I
      ML_DFLOAT = DBLE(I)
      RETURN
      END FUNCTION ML_DFLOAT

!-----------------------------------------------------------------------

!end module matlab_module