home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Club Amiga de Montreal - CAM
/
CAM_CD_1.iso
/
files
/
172.lha
/
Matlab.for
< prev
next >
Wrap
Text File
|
1988-04-28
|
312KB
|
7,569 lines
C PROGRAM MAIN FOR Amiga
PROGRAM BIGMAT
CALL MATLAB(0)
STOP
END
SUBROUTINE CLAUSE
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER FOR(4),WHILE(4),IFF(4),ELSE(4),ENND(4),DO(4),THENN(4)
INTEGER SEMI,EQUAL,EOL,BLANK,R
INTEGER OP,COMMA,LESS,GREAT,NAME
LOGICAL EQID
DOUBLE PRECISION E1,E2
DATA SEMI/39/,EQUAL/46/,EOL/99/,BLANK/36/
DATA COMMA/48/,LESS/50/,GREAT/51/,NAME/1/
DATA FOR/15,24,27,36/,WHILE/32,17,18,21/,IFF/18,15,36,36/
DATA ELSE/14,21,28,14/,ENND/14,23,13,36/
DATA DO/13,24,36,36/,THENN/29,17,14,23/
R = -FIN-10
FIN = 0
IF (DDT .EQ. 1) WRITE(WTE,100) PT,RSTK(PT),R
100 FORMAT(1X,'CLAUSE',3I4)
IF (R.LT.1 .OR. R.GT.6) GO TO 01
GO TO (02,30,30,80,99,90),R
01 R = RSTK(PT)
GO TO (99,99,05,40,45,99,99,99,99,99,99,99,15,55,99,99,99),R
C
C FOR
C
02 CALL GETSYM
IF (SYM .NE. NAME) CALL ERROR(34)
IF (ERR .GT. 0) RETURN
PT = PT+2
CALL PUTID(IDS(1,PT),SYN)
CALL GETSYM
IF (SYM .NE. EQUAL) CALL ERROR(34)
IF (ERR .GT. 0) RETURN
CALL GETSYM
RSTK(PT) = 3
C *CALL* EXPR
RETURN
05 PSTK(PT-1) = 0
PSTK(PT) = LPT(4) - 1
IF (EQID(SYN,DO)) SYM = SEMI
IF (SYM .EQ. COMMA) SYM = SEMI
IF (SYM .NE. SEMI) CALL ERROR(34)
IF (ERR .GT. 0) RETURN
10 J = PSTK(PT-1)
LPT(4) = PSTK(PT)
SYM = SEMI
CHAR = BLANK
J = J+1
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
LJ = L+(J-1)*M
L2 = L + M*N
IF (M .NE. -3) GO TO 12
LJ = L+3
L2 = LJ
STKR(LJ) = STKR(L) + DFLOAT(J-1)*STKR(L+1)
STKI(LJ) = 0.0
IF (STKR(L+1).GT.0.0D0 .AND. STKR(LJ).GT.STKR(L+2)) GO TO 20
IF (STKR(L+1).LT.0.0D0 .AND. STKR(LJ).LT.STKR(L+2)) GO TO 20
M = 1
N = J
12 IF (J .GT. N) GO TO 20
IF (TOP+1 .GE. BOT) CALL ERROR(18)
IF (ERR .GT. 0) RETURN
TOP = TOP+1
LSTK(TOP) = L2
MSTK(TOP) = M
NSTK(TOP) = 1
ERR = L2+M - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
CALL WCOPY(M,STKR(LJ),STKI(LJ),1,STKR(L2),STKI(L2),1)
RHS = 0
CALL STACKP(IDS(1,PT))
IF (ERR .GT. 0) RETURN
PSTK(PT-1) = J
PSTK(PT) = LPT(4)
RSTK(PT) = 13
C *CALL* PARSE
RETURN
15 GO TO 10
20 MSTK(TOP) = 0
NSTK(TOP) = 0
RHS = 0
CALL STACKP(IDS(1,PT))
IF (ERR .GT. 0) RETURN
PT = PT-2
GO TO 80
C
C WHILE OR IF
C
30 PT = PT+1
CALL PUTID(IDS(1,PT),SYN)
PSTK(PT) = LPT(4)-1
35 LPT(4) = PSTK(PT)
CHAR = BLANK
CALL GETSYM
RSTK(PT) = 4
C *CALL* EXPR
RETURN
40 IF (SYM.NE.EQUAL .AND. SYM.NE.LESS .AND. SYM.NE.GREAT)
$ CALL ERROR(35)
IF (ERR .GT. 0) RETURN
OP = SYM
CALL GETSYM
IF (SYM.EQ.EQUAL .OR. SYM.EQ.GREAT) OP = OP + SYM
IF (OP .GT. GREAT) CALL GETSYM
PSTK(PT) = 256*PSTK(PT) + OP
RSTK(PT) = 5
C *CALL* EXPR
RETURN
45 OP = MOD(PSTK(PT),256)
PSTK(PT) = PSTK(PT)/256
L = LSTK(TOP-1)
E1 = STKR(L)
L = LSTK(TOP)
E2 = STKR(L)
TOP = TOP - 2
IF (EQID(SYN,DO) .OR. EQID(SYN,THENN)) SYM = SEMI
IF (SYM .EQ. COMMA) SYM = SEMI
IF (SYM .NE. SEMI) CALL ERROR(35)
IF (ERR .GT. 0) RETURN
IF (OP.EQ.EQUAL .AND. E1.EQ.E2) GO TO 50
IF (OP.EQ.LESS .AND. E1.LT.E2) GO TO 50
IF (OP.EQ.GREAT .AND. E1.GT.E2) GO TO 50
IF (OP.EQ.(LESS+EQUAL) .AND. E1.LE.E2) GO TO 50
IF (OP.EQ.(GREAT+EQUAL) .AND. E1.GE.E2) GO TO 50
IF (OP.EQ.(LESS+GREAT) .AND. E1.NE.E2) GO TO 50
PT = PT-1
GO TO 80
50 RSTK(PT) = 14
C *CALL* PARSE
RETURN
55 IF (EQID(IDS(1,PT),WHILE)) GO TO 35
PT = PT-1
IF (EQID(SYN,ELSE)) GO TO 80
RETURN
C
C SEARCH FOR MATCHING END OR ELSE
80 KOUNT = 0
CALL GETSYM
82 IF (SYM .EQ. EOL) RETURN
IF (SYM .NE. NAME) GO TO 83
IF (EQID(SYN,ENND) .AND. KOUNT.EQ.0) RETURN
IF (EQID(SYN,ELSE) .AND. KOUNT.EQ.0) RETURN
IF (EQID(SYN,ENND) .OR. EQID(SYN,ELSE))
$ KOUNT = KOUNT-1
IF (EQID(SYN,FOR) .OR. EQID(SYN,WHILE)
$ .OR. EQID(SYN,IFF)) KOUNT = KOUNT+1
83 CALL GETSYM
GO TO 82
C
C EXIT FROM LOOP
90 IF (DDT .EQ. 1) WRITE(WTE,190) (RSTK(I),I=1,PT)
190 FORMAT(1X,'EXIT ',10I4)
IF (RSTK(PT) .EQ. 14) PT = PT-1
IF (PT .LE. PTZ) RETURN
IF (RSTK(PT) .EQ. 14) PT = PT-1
IF (PT-1 .LE. PTZ) RETURN
IF (RSTK(PT) .EQ. 13) TOP = TOP-1
IF (RSTK(PT) .EQ. 13) PT = PT-2
GO TO 80
C
99 CALL ERROR(22)
IF (ERR .GT. 0) RETURN
RETURN
END
SUBROUTINE COMAND(ID)
INTEGER ID(4)
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER ALFA(52),ALFB(52),ALFL,CASE
INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /ALFS/ ALFA,ALFB,ALFL,CASE
COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER CMD(4,17),CMDL,A,D,E,Z,LRECL,CH,BLANK,NAME,DOT,H(4)
INTEGER SEMI,COMMA,EOL
DOUBLE PRECISION URAND
LOGICAL EQID
DATA CMDL/17/,A/10/,D/13/,E/14/,Z/35/,EOL/99/,SEMI/39/,COMMA/48/
DATA BLANK/36/,NAME/1/,DOT/47/
C
C CLEAR ELSE END EXIT
C FOR HELP IF LONG
C RETUR SEMI
C SHORT WHAT WHILE
C WHO WHY LALA FOO
DATA CMD/
$ 12,21,14,10, 14,21,28,14, 14,23,13,36, 14,33,18,29,
$ 15,24,27,36, 17,14,21,25, 18,15,36,36, 21,24,23,16,
$ 27,14,29,30, 28,14,22,18,
$ 28,17,24,27, 32,17,10,29, 32,17,18,21,
$ 32,17,24,36, 32,17,34,36, 21,10,21,10, 15,30,12,20/
C
DATA LRECL/80/
101 FORMAT(80A1)
102 FORMAT(1X,80A1)
C
IF (DDT .EQ. 1) WRITE(WTE,100)
100 FORMAT(1X,'COMAND')
FUN = 0
DO 10 K = 1, CMDL
IF (EQID(ID,CMD(1,K))) GO TO 20
10 CONTINUE
FIN = 0
RETURN
C
20 IF (CHAR.EQ.COMMA .OR. CHAR.EQ.SEMI .OR. CHAR.EQ.EOL) GO TO 22
IF (CHAR.LE.Z .OR. K.EQ.6) GO TO 22
CALL ERROR(16)
RETURN
C
22 FIN = 1
GO TO (25,36,38,40,30,80,34,52,44,55,50,65,32,60,70,46,48),K
C
C CLEAR
25 IF (CHAR.GE.A .AND. CHAR.LE.Z) GO TO 26
BOT = LSIZE-3
GO TO 98
26 CALL GETSYM
TOP = TOP+1
MSTK(TOP) = 0
NSTK(TOP) = 0
RHS = 0
CALL STACKP(SYN)
IF (ERR .GT. 0) RETURN
FIN = 1
GO TO 98
C
C FOR, WHILE, IF, ELSE, END
30 FIN = -11
GO TO 99
32 FIN = -12
GO TO 99
34 FIN = -13
GO TO 99
36 FIN = -14
GO TO 99
38 FIN = -15
GO TO 99
C
C EXIT
40 IF (PT .GT. PTZ) FIN = -16
IF (PT .GT. PTZ) GO TO 98
K = IDINT(STKR(VSIZE-2))
WRITE(WTE,140) K
IF (WIO .NE. 0) WRITE(WIO,140) K
140 FORMAT(/1X,'total flops ',I9//1X,'ADIOS'/)
FUN = 99
GO TO 98
C
C RETURN
44 K = LPT(1) - 7
IF (K .LE. 0) FUN = 99
IF (K .LE. 0) GO TO 98
CALL FILES(-1*RIO,BUF)
LPT(1) = LIN(K+1)
LPT(4) = LIN(K+2)
LPT(6) = LIN(K+3)
PTZ = LIN(K+4)
RIO = LIN(K+5)
LCT(4) = LIN(K+6)
CHAR = BLANK
SYM = COMMA
GO TO 99
C
C LALA
46 WRITE(WTE,146)
146 FORMAT(1X,'QUIT SINGING AND GET BACK TO WORK.')
GO TO 98
C
C FOO
48 WRITE(WTE,148)
148 FORMAT(1X,'YOUR PLACE OR MINE')
GO TO 98
C
C SHORT, LONG
50 FMT = 1
GO TO 54
52 FMT = 2
54 IF (CHAR.EQ.E .OR. CHAR.EQ.D) FMT = FMT+2
IF (CHAR .EQ. Z) FMT = 5
IF (CHAR.EQ.E .OR. CHAR.EQ.D .OR. CHAR.EQ.Z) CALL GETSYM
GO TO 98
C
C SEMI
55 LCT(3) = 1 - LCT(3)
GO TO 98
C
C WHO
60 WRITE(WTE,160)
IF (WIO .NE. 0) WRITE(WIO,160)
160 FORMAT(1X,'Your current variables are...')
CALL PRNTID(IDSTK(1,BOT),LSIZE-BOT+1)
L = VSIZE-LSTK(BOT)+1
WRITE(WTE,161) L,VSIZE
IF (WIO .NE. 0) WRITE(WIO,161) L,VSIZE
161 FORMAT(1X,'using ',I7,' out of ',I7,' elements.')
GO TO 98
C
C WHAT
65 WRITE(WTE,165)
165 FORMAT(1X,'The functions and commands are...')
H(1) = 0
CALL FUNS(H)
CALL PRNTID(CMD,CMDL-2)
GO TO 98
C
C WHY
70 K = IDINT(9.0D0*URAND(RAN(1))+1.0D0)
GO TO (71,72,73,74,75,76,77,78,79),K
71 WRITE(WTE,171)
171 FORMAT(1X,'WHAT?')
GO TO 98
72 WRITE(WTE,172)
172 FORMAT(1X,'R.T.F.M.')
GO TO 98
73 WRITE(WTE,173)
173 FORMAT(1X,'HOW THE HELL SHOULD I KNOW?')
GO TO 98
74 WRITE(WTE,174)
174 FORMAT(1X,'PETE MADE ME DO IT.')
GO TO 98
75 WRITE(WTE,175)
175 FORMAT(1X,'INSUFFICIENT DATA TO ANSWER.')
GO TO 98
76 WRITE(WTE,176)
176 FORMAT(1X,'IT FEELS GOOD.')
GO TO 98
77 WRITE(WTE,177)
177 FORMAT(1X,'WHY NOT?')
GO TO 98
78 WRITE(WTE,178)
178 FORMAT(1X,'/--ERROR'/1X,'STUPID QUESTION.')
GO TO 98
79 WRITE(WTE,179)
179 FORMAT(1X,'SYSTEM ERROR, RETRY')
GO TO 98
C
C HELP
80 IF (CHAR .NE. EOL) GO TO 81
WRITE(WTE,180)
IF (WIO .NE. 0) WRITE(WIO,180)
180 FORMAT(1X,'Type HELP followed by ...'
$ /1X,'INTRO (To get started)'
$ /1X,'NEWS (recent revisions)')
H(1) = 0
CALL FUNS(H)
CALL PRNTID(CMD,CMDL-2)
J = BLANK+2
WRITE(WTE,181)
IF (WIO .NE. 0) WRITE(WIO,181)
181 FORMAT(1X,'ANS EDIT FILE FUN MACRO')
WRITE(WTE,182) (ALFA(I),I=J,ALFL)
IF (WIO .NE. 0) WRITE(WIO,182) (ALFA(I),I=J,ALFL)
182 FORMAT(1X,17(A1,1X)/)
GO TO 98
C
81 CALL GETSYM
IF (SYM .EQ. NAME) GO TO 82
IF (SYM .EQ. 0) SYM = DOT
H(1) = ALFA(SYM+1)
H(2) = ALFA(BLANK+1)
H(3) = ALFA(BLANK+1)
H(4) = ALFA(BLANK+1)
GO TO 84
82 DO 83 I = 1, 4
CH = SYN(I)
H(I) = ALFA(CH+1)
83 CONTINUE
84 IF(HIO .NE. 0) THEN
READ(HIO,101,END=89) (BUF(I),I=1,LRECL)
CDC.. IF (EOF(HIO).NE.0) GO TO 89
DO 85 I = 1, 4
IF (H(I) .NE. BUF(I)) GO TO 84
85 CONTINUE
WRITE(WTE,102)
IF (WIO .NE. 0) WRITE(WIO,102)
86 K = LRECL + 1
87 K = K - 1
IF (BUF(K) .EQ. ALFA(BLANK+1)) GO TO 87
WRITE(WTE,102) (BUF(I),I=1,K)
IF (WIO .NE. 0) WRITE(WIO,102) (BUF(I),I=1,K)
READ(HIO,101) (BUF(I),I=1,LRECL)
IF (BUF(1) .EQ. ALFA(BLANK+1)) GO TO 86
CALL FILES(-HIO,BUF)
GO TO 98
ENDIF
C
89 WRITE(WTE,189) (H(I),I=1,4)
189 FORMAT(1X,'SORRY, NO HELP ON ',4A1)
CALL FILES(-HIO,BUF)
GO TO 98
C
98 CALL GETSYM
99 RETURN
END
SUBROUTINE EDIT(BUF,N)
INTEGER BUF(N)
C
C CALLED AFTER INPUT OF A SINGLE BACKSLASH
C BUF CONTAINS PREVIOUS INPUT LINE, ONE CHAR PER WORD
C ENTER LOCAL EDITOR IF AVAILABLE
C OTHERWISE JUST
RETURN
END
SUBROUTINE ERROR(N)
INTEGER N
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ
INTEGER ALFA(52),ALFB(52),ALFL,CASE
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ
COMMON /ALFS/ ALFA,ALFB,ALFL,CASE
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER ERRMSG(8),BLH,BEL
DATA ERRMSG /1H/,1H-,1H-,1HE,1HR,1HR,1HO,1HR/,BLH/1H /,BEL/1H /
C SET BEL TO CTRL-G IF POSSIBLE
C
K = LPT(2) - LPT(1)
IF (K .LT. 1) K = 1
LUNIT = WTE
98 WRITE(LUNIT,100) (BLH,I=1,K),(ERRMSG(I),I=1,8),BEL
100 FORMAT(1X,80A1)
GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,
$ 23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40),N
C
1 WRITE(LUNIT,101)
101 FORMAT(1X,'IMPROPER MULTIPLE ASSIGNMENT')
GO TO 99
2 WRITE(LUNIT,102)
102 FORMAT(1X,'IMPROPER FACTOR')
GO TO 99
3 WRITE(LUNIT,103)
103 FORMAT(1X,'EXPECT RIGHT PARENTHESIS')
GO TO 99
4 DO 94 I = 1, 4
K = IDS(I,PT+1)
BUF(I) = ALFA(K+1)
94 CONTINUE
WRITE(LUNIT,104) (BUF(I),I=1,4)
104 FORMAT(1X,'UNDEFINED VARIABLE: ',4A1)
GO TO 99
5 WRITE(LUNIT,105)
105 FORMAT(1X,'COLUMN LENGTHS DO NOT MATCH')
GO TO 99
6 WRITE(LUNIT,106)
106 FORMAT(1X,'ROW LENGTHS DO NOT MATCH')
GO TO 99
7 WRITE(LUNIT,107)
107 FORMAT(1X,'TEXT TOO LONG')
GO TO 99
8 WRITE(LUNIT,108)
108 FORMAT(1X,'INCOMPATIBLE FOR ADDITION')
GO TO 99
9 WRITE(LUNIT,109)
109 FORMAT(1X,'INCOMPATIBLE FOR SUBTRACTION')
GO TO 99
10 WRITE(LUNIT,110)
110 FORMAT(1X,'INCOMPATIBLE FOR MULTIPLICATION')
GO TO 99
11 WRITE(LUNIT,111)
111 FORMAT(1X,'INCOMPATIBLE FOR RIGHT DIVISION')
GO TO 99
12 WRITE(LUNIT,112)
112 FORMAT(1X,'INCOMPATIBLE FOR LEFT DIVISION')
GO TO 99
13 WRITE(LUNIT,113)
113 FORMAT(1X,'IMPROPER ASSIGNMENT TO PERMANENT VARIABLE')
GO TO 99
14 WRITE(LUNIT,114)
114 FORMAT(1X,'EYE-DENTITY UNDEFINED BY CONTEXT')
GO TO 99
15 WRITE(LUNIT,115)
115 FORMAT(1X,'IMPROPER ASSIGNMENT TO SUBMATRIX')
GO TO 99
16 WRITE(LUNIT,116)
116 FORMAT(1X,'IMPROPER COMMAND')
GO TO 99
17 LB = VSIZE - LSTK(BOT) + 1
LT = ERR + LSTK(BOT)
WRITE(LUNIT,117) LB,LT,VSIZE
117 FORMAT(1X,'TOO MUCH MEMORY REQUIRED'
$ /1X,' ',I7,' VARIABLES,',I7,' TEMPORARIES,',I7,' AVAILABLE.')
GO TO 99
18 WRITE(LUNIT,118)
118 FORMAT(1X,'TOO MANY NAMES')
GO TO 99
19 WRITE(LUNIT,119)
119 FORMAT(1X,'MATRIX IS SINGULAR TO WORKING PRECISION')
GO TO 99
20 WRITE(LUNIT,120)
120 FORMAT(1X,'MATRIX MUST BE SQUARE')
GO TO 99
21 WRITE(LUNIT,121)
121 FORMAT(1X,'SUBSCRIPT OUT OF RANGE')
GO TO 99
22 WRITE(LUNIT,122) (RSTK(I),I=1,PT)
122 FORMAT(1X,'RECURSION DIFFICULTIES',10I4)
GO TO 99
23 WRITE(LUNIT,123)
123 FORMAT(1X,'ONLY 1, 2 OR INF NORM OF MATRIX')
GO TO 99
24 WRITE(LUNIT,124)
124 FORMAT(1X,'NO CONVERGENCE')
GO TO 99
25 WRITE(LUNIT,125)
125 FORMAT(1X,'CAN NOT USE FUNCTION NAME AS VARIABLE')
GO TO 99
26 WRITE(LUNIT,126)
126 FORMAT(1X,'TOO COMPLICATED (STACK OVERFLOW)')
GO TO 99
27 WRITE(LUNIT,127)
127 FORMAT(1X,'DIVISION BY ZERO IS A NO-NO')
GO TO 99
28 WRITE(LUNIT,128)
128 FORMAT(1X,'EMPTY MACRO')
GO TO 99
29 WRITE(LUNIT,129)
129 FORMAT(1X,'NOT POSITIVE DEFINITE')
GO TO 99
30 WRITE(LUNIT,130)
130 FORMAT(1X,'IMPROPER EXPONENT')
GO TO 99
31 WRITE(LUNIT,131)
131 FORMAT(1X,'IMPROPER STRING')
GO TO 99
32 WRITE(LUNIT,132)
132 FORMAT(1X,'SINGULARITY OF LOG OR ATAN')
GO TO 99
33 WRITE(LUNIT,133)
133 FORMAT(1X,'TOO MANY COLONS')
GO TO 99
34 WRITE(LUNIT,134)
134 FORMAT(1X,'IMPROPER FOR CLAUSE')
GO TO 99
35 WRITE(LUNIT,135)
135 FORMAT(1X,'IMPROPER WHILE OR IF CLAUSE')
GO TO 99
36 WRITE(LUNIT,136)
136 FORMAT(1X,'ARGUMENT OUT OF RANGE')
GO TO 99
37 WRITE(LUNIT,137)
137 FORMAT(1X,'IMPROPER MACRO')
GO TO 99
38 WRITE(LUNIT,138)
138 FORMAT(1X,'IMPROPER FILE NAME')
GO TO 99
39 WRITE(LUNIT,139)
139 FORMAT(1X,'INCORRECT NUMBER OF ARGUMENTS')
GO TO 99
40 WRITE(LUNIT,140)
140 FORMAT(1X,'EXPECT STATEMENT TERMINATOR')
GO TO 99
C
99 ERR = N
IF (LUNIT.EQ.WIO .OR. WIO.EQ.0) RETURN
LUNIT = WIO
GO TO 98
END
SUBROUTINE EXPR
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER OP,R,BLANK,SIGN,PLUS,MINUS,NAME,COLON,EYE(4)
DATA COLON/40/,BLANK/36/,PLUS/41/,MINUS/42/,NAME/1/
DATA EYE/14,34,14,36/
IF (DDT .EQ. 1) WRITE(WTE,100) PT,RSTK(PT)
100 FORMAT(1X,'EXPR ',2I4)
R = RSTK(PT)
GO TO (01,01,01,01,01,05,25,99,99,01,01,99,99,99,99,99,99,01,01,
$ 01),R
01 IF (SYM .EQ. COLON) CALL PUTID(SYN,EYE)
IF (SYM .EQ. COLON) SYM = NAME
KOUNT = 1
02 SIGN = PLUS
IF (SYM .EQ. MINUS) SIGN = MINUS
IF (SYM.EQ.PLUS .OR. SYM.EQ.MINUS) CALL GETSYM
PT = PT+1
IF (PT .GT. PSIZE-1) CALL ERROR(26)
IF (ERR .GT. 0) RETURN
PSTK(PT) = SIGN + 256*KOUNT
RSTK(PT) = 6
C *CALL* TERM
RETURN
05 SIGN = MOD(PSTK(PT),256)
KOUNT = PSTK(PT)/256
PT = PT-1
IF (SIGN .EQ. MINUS) CALL STACK1(MINUS)
IF (ERR .GT. 0) RETURN
10 IF (SYM.EQ.PLUS .OR. SYM.EQ.MINUS) GO TO 20
GO TO 50
20 IF (RSTK(PT) .NE. 10) GO TO 21
C BLANK IS DELIMITER INSIDE ANGLE BRACKETS
LS = LPT(3) - 2
IF (LIN(LS) .EQ. BLANK) GO TO 50
21 OP = SYM
CALL GETSYM
PT = PT+1
PSTK(PT) = OP + 256*KOUNT
RSTK(PT) = 7
C *CALL* TERM
RETURN
25 OP = MOD(PSTK(PT),256)
KOUNT = PSTK(PT)/256
PT = PT-1
CALL STACK2(OP)
IF (ERR .GT. 0) RETURN
GO TO 10
50 IF (SYM .NE. COLON) GO TO 60
CALL GETSYM
KOUNT = KOUNT+1
GO TO 02
60 IF (KOUNT .GT. 3) CALL ERROR(33)
IF (ERR .GT. 0) RETURN
RHS = KOUNT
IF (KOUNT .GT. 1) CALL STACK2(COLON)
IF (ERR .GT. 0) RETURN
RETURN
99 CALL ERROR(22)
IF (ERR .GT. 0) RETURN
RETURN
END
SUBROUTINE FACTOR
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER SEMI,EOL,BLANK,R,ID(4),EXCNT,LPAREN,RPAREN
INTEGER STAR,DSTAR,COMMA,LESS,GREAT,QUOTE,NUM,NAME,ALFL
DATA DSTAR/54/,SEMI/39/,EOL/99/,BLANK/36/
DATA STAR/43/,COMMA/48/,LPAREN/37/,RPAREN/38/
DATA LESS/50/,GREAT/51/,QUOTE/49/,NUM/0/,NAME/1/,ALFL/52/
IF (DDT .EQ. 1) WRITE(WTE,100) PT,RSTK(PT),SYM
100 FORMAT(1X,'FACTOR',3I4)
R = RSTK(PT)
GO TO (99,99,99,99,99,99,99,01,01,25,45,65,99,99,99,55,75,32,37),R
01 IF (SYM.EQ.NUM .OR. SYM.EQ.QUOTE .OR. SYM.EQ.LESS) GO TO 10
IF (SYM .EQ. GREAT) GO TO 30
EXCNT = 0
IF (SYM .EQ. NAME) GO TO 40
ID(1) = BLANK
IF (SYM .EQ. LPAREN) GO TO 42
CALL ERROR(2)
IF (ERR .GT. 0) RETURN
C
C PUT SOMETHING ON THE STACK
10 L = 1
IF (TOP .GT. 0) L = LSTK(TOP) + MSTK(TOP)*NSTK(TOP)
IF (TOP+1 .GE. BOT) CALL ERROR(18)
IF (ERR .GT. 0) RETURN
TOP = TOP+1
LSTK(TOP) = L
IF (SYM .EQ. QUOTE) GO TO 15
IF (SYM .EQ. LESS) GO TO 20
C
C SINGLE NUMBER, GETSYM STORED IT IN STKI
MSTK(TOP) = 1
NSTK(TOP) = 1
STKR(L) = STKI(VSIZE)
STKI(L) = 0.0D0
CALL GETSYM
GO TO 60
C
C STRING
15 N = 0
LPT(4) = LPT(3)
CALL GETCH
16 IF (CHAR .EQ. QUOTE) GO TO 18
17 LN = L+N
IF (CHAR .EQ. EOL) CALL ERROR(31)
IF (ERR .GT. 0) RETURN
STKR(LN) = DFLOAT(CHAR)
STKI(LN) = 0.0D0
N = N+1
CALL GETCH
GO TO 16
18 CALL GETCH
IF (CHAR .EQ. QUOTE) GO TO 17
IF (N .LE. 0) CALL ERROR(31)
IF (ERR .GT. 0) RETURN
MSTK(TOP) = 1
NSTK(TOP) = N
CALL GETSYM
GO TO 60
C
C EXPLICIT MATRIX
20 MSTK(TOP) = 0
NSTK(TOP) = 0
21 TOP = TOP + 1
LSTK(TOP) = LSTK(TOP-1) + MSTK(TOP-1)*NSTK(TOP-1)
MSTK(TOP) = 0
NSTK(TOP) = 0
CALL GETSYM
22 IF (SYM.EQ.SEMI .OR. SYM.EQ.GREAT .OR. SYM.EQ.EOL) GO TO 27
IF (SYM .EQ. COMMA) CALL GETSYM
PT = PT+1
RSTK(PT) = 10
C *CALL* EXPR
RETURN
25 PT = PT-1
TOP = TOP - 1
IF (MSTK(TOP) .EQ. 0) MSTK(TOP) = MSTK(TOP+1)
IF (MSTK(TOP) .NE. MSTK(TOP+1)) CALL ERROR(5)
IF (ERR .GT. 0) RETURN
NSTK(TOP) = NSTK(TOP) + NSTK(TOP+1)
GO TO 22
27 IF (SYM.EQ.SEMI .AND. CHAR.EQ.EOL) CALL GETSYM
CALL STACK1(QUOTE)
IF (ERR .GT. 0) RETURN
TOP = TOP - 1
IF (MSTK(TOP) .EQ. 0) MSTK(TOP) = MSTK(TOP+1)
IF (MSTK(TOP).NE.MSTK(TOP+1) .AND. MSTK(TOP+1).GT.0) CALL ERROR(6)
IF (ERR .GT. 0) RETURN
NSTK(TOP) = NSTK(TOP) + NSTK(TOP+1)
IF (SYM .EQ. EOL) CALL GETLIN
IF (SYM .NE. GREAT) GO TO 21
CALL STACK1(QUOTE)
IF (ERR .GT. 0) RETURN
CALL GETSYM
GO TO 60
C
C MACRO STRING
30 CALL GETSYM
IF (SYM.EQ.LESS .AND. CHAR.EQ.EOL) CALL ERROR(28)
IF (ERR .GT. 0) RETURN
PT = PT+1
RSTK(PT) = 18
C *CALL* EXPR
RETURN
32 PT = PT-1
IF (SYM.NE.LESS .AND. SYM.NE.EOL) CALL ERROR(37)
IF (ERR .GT. 0) RETURN
IF (SYM .EQ. LESS) CALL GETSYM
K = LPT(6)
LIN(K+1) = LPT(1)
LIN(K+2) = LPT(2)
LIN(K+3) = LPT(6)
LPT(1) = K + 4
C TRANSFER STACK TO INPUT LINE
K = LPT(1)
L = LSTK(TOP)
N = MSTK(TOP)*NSTK(TOP)
DO 34 J = 1, N
LS = L + J-1
LIN(K) = IDINT(STKR(LS))
IF (LIN(K).LT.0 .OR. LIN(K).GE.ALFL) CALL ERROR(37)
IF (ERR .GT. 0) RETURN
IF (K.LT.1024) K = K+1
IF (K.EQ.1024) WRITE(WTE,33) K
33 FORMAT(1X,'INPUT BUFFER LIMIT IS ',I4,' CHARACTERS.')
34 CONTINUE
TOP = TOP-1
LIN(K) = EOL
LPT(6) = K
LPT(4) = LPT(1)
LPT(3) = 0
LPT(2) = 0
LCT(1) = 0
CHAR = BLANK
CALL GETSYM
PT = PT+1
RSTK(PT) = 19
C *CALL* EXPR
RETURN
37 PT = PT-1
K = LPT(1) - 4
LPT(1) = LIN(K+1)
LPT(4) = LIN(K+2)
LPT(6) = LIN(K+3)
CHAR = BLANK
CALL GETSYM
GO TO 60
C
C FUNCTION OR MATRIX ELEMENT
40 CALL PUTID(ID,SYN)
CALL GETSYM
IF (SYM .EQ. LPAREN) GO TO 42
RHS = 0
CALL FUNS(ID)
IF (FIN .NE. 0) CALL ERROR(25)
IF (ERR .GT. 0) RETURN
CALL STACKG(ID)
IF (ERR .GT. 0) RETURN
IF (FIN .EQ. 7) GO TO 50
IF (FIN .EQ. 0) CALL PUTID(IDS(1,PT+1),ID)
IF (FIN .EQ. 0) CALL ERROR(4)
IF (ERR .GT. 0) RETURN
GO TO 60
C
42 CALL GETSYM
EXCNT = EXCNT+1
PT = PT+1
PSTK(PT) = EXCNT
CALL PUTID(IDS(1,PT),ID)
RSTK(PT) = 11
C *CALL* EXPR
RETURN
45 CALL PUTID(ID,IDS(1,PT))
EXCNT = PSTK(PT)
PT = PT-1
IF (SYM .EQ. COMMA) GO TO 42
IF (SYM .NE. RPAREN) CALL ERROR(3)
IF (ERR .GT. 0) RETURN
IF (SYM .EQ. RPAREN) CALL GETSYM
IF (ID(1) .EQ. BLANK) GO TO 60
RHS = EXCNT
CALL STACKG(ID)
IF (ERR .GT. 0) RETURN
IF (FIN .EQ. 0) CALL FUNS(ID)
IF (FIN .EQ. 0) CALL ERROR(4)
IF (ERR .GT. 0) RETURN
C
C EVALUATE MATRIX FUNCTION
50 PT = PT+1
RSTK(PT) = 16
C *CALL* MATFN
RETURN
55 PT = PT-1
GO TO 60
C
C CHECK FOR QUOTE (TRANSPOSE) AND ** (POWER)
60 IF (SYM .NE. QUOTE) GO TO 62
I = LPT(3) - 2
IF (LIN(I) .EQ. BLANK) GO TO 90
CALL STACK1(QUOTE)
IF (ERR .GT. 0) RETURN
CALL GETSYM
62 IF (SYM.NE.STAR .OR. CHAR.NE.STAR) GO TO 90
CALL GETSYM
CALL GETSYM
PT = PT+1
RSTK(PT) = 12
C *CALL* FACTOR
GO TO 01
65 PT = PT-1
CALL STACK2(DSTAR)
IF (ERR .GT. 0) RETURN
IF (FUN .NE. 2) GO TO 90
C MATRIX POWER, USE EIGENVECTORS
PT = PT+1
RSTK(PT) = 17
C *CALL* MATFN
RETURN
75 PT = PT-1
90 RETURN
99 CALL ERROR(22)
IF (ERR .GT. 0) RETURN
RETURN
END
SUBROUTINE FILES(LUNIT,NAME)
INTEGER LUNIT
C
C AMIGA SPECIFIC ROUTINE TO ALLOCATE FILES
C LUNIT = LOGICAL UNIT NUMBER
C NAME = FILE NAME, 1 CHARACTER PER WORD
C
character*1024 NAME
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
C
C Amiga dependent stuff to squeeze the NAME from one char per word to one
C per byte
C
character*1024 NAME2
integer*1 strip(4,256),strip2(32)
character*32 NAME3
equivalence (NAME2,strip),(NAME3,strip2)
C
FE=0
C
C ERROR CATCHER
IF (LUNIT .EQ. 0) RETURN
C
C PRINTER
if (LUNIT .eq. 6) return
C
C TERMINAL I/O
if (LUNIT .eq. 9) return
C
C HELP FILE
if (LUNIT .eq. 11) then
OPEN(11,FILE='HELP.LIS',STATUS='OLD',ERR=14)
write(9,09)
09 format(/1X,'HELP is available')
return
end if
if (LUNIT .eq. -11 .AND. HIO .NE. 0) then
rewind (11,ERR=99)
return
end if
if (LUNIT .lt. 0) then
close(unit=-LUNIT,ERR=99)
return
end if
10 continue
C
C ALL OTHER FILES
C
NAME2=NAME
do 37 j=1,32
37 strip2(j)=strip(1,j)
OPEN(UNIT=LUNIT,FILE=NAME3,STATUS='UNKNOWN',ERR=98)
RETURN
14 WRITE(9,15)
C
C HELP FILE NOT FOUND
C
15 FORMAT(1X,'HELP IS NOT AVAILABLE')
HIO = 0
RETURN
C
C GENERAL FILE OPEN FAILURE
C
98 WRITE(9,16)
16 FORMAT(1X,'OPEN FILE FAILED')
FE=1
C IF THIS WAS A DIARY FILE (OUTPUT), SET ITS FILE HANDLE TO 0
IF(LUNIT .EQ. 8) THEN
WIO=0
C
C OTHERWISE, SET THE I/O TO TERMINAL I/O
C
ELSE
RIO=RTE
ENDIF
RETURN
99 CONTINUE
RETURN
END
DOUBLE PRECISION FUNCTION FLOP(X)
DOUBLE PRECISION X
C SYSTEM DEPENDENT FUNCTION
C COUNT AND POSSIBLY CHOP EACH FLOATING POINT OPERATION
C FLP(1) IS FLOP COUNTER
C FLP(2) IS NUMBER OF PLACES TO BE CHOPPED
C
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
C
DOUBLE PRECISION MASK(14),XX,MM
real mas(2,14)
LOGICAL LX(2),LM(2)
EQUIVALENCE (LX(1),XX),(LM(1),MM)
equivalence (MASK(1),mas(1))
data mas/
$ Z'ffffffff',Z'fff0ffff',
$ Z'ffffffff',Z'ff00ffff',
$ Z'ffffffff',Z'f000ffff',
$ Z'ffffffff',Z'0000ffff',
$ Z'ffffffff',Z'0000fff0',
$ Z'ffffffff',Z'0000ff00',
$ Z'ffffffff',Z'0000f000',
$ Z'ffffffff',Z'00000000',
$ Z'fff0ffff',Z'00000000',
$ Z'ff00ffff',Z'00000000',
$ Z'f000ffff',Z'00000000',
$ Z'0000ffff',Z'00000000',
$ Z'0000fff0',Z'00000000',
$ Z'0000ff80',Z'00000000'/
C
FLP(1) = FLP(1) + 1
K = FLP(2)
FLOP = X
IF (K .LE. 0) RETURN
FLOP = 0.0D0
IF (K .GE. 15) RETURN
XX = X
MM = MASK(K)
LX(1) = LX(1) .AND. LM(1)
LX(2) = LX(2) .AND. LM(2)
FLOP = XX
RETURN
END
SUBROUTINE FORMZ(LUNIT,X,Y)
DOUBLE PRECISION X,Y
C
C SYSTEM DEPENDENT ROUTINE TO PRINT WITH Z FORMAT
C
IF (Y .NE. 0.0D0) WRITE(LUNIT,10) X,Y
IF (Y .EQ. 0.0D0) WRITE(LUNIT,10) X
10 FORMAT(2Z18)
RETURN
END
SUBROUTINE FUNS(ID)
INTEGER ID(4)
C
C SCAN FUNCTION LIST
C
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
LOGICAL EQID
INTEGER FUNL,FUNN(4,57),FUNP(57)
DATA FUNL/57/
C
C 1 ABS ATAN BASE CHAR
C 2 CHOL CHOP COND CONJ
C 3 COS DET DIAG DIAR
C 4 DISP EIG EPS EXEC
C 5 EXP EYE FLOP HESS
C 6 HILB IMAG INV KRON
C 7 LINE LOAD LOG LU
C 8 MAGIC NORM ONES ORTH
C 9 PINV PLOT POLY PRINT
C $ PROD QR RAND RANK
C 1 RAT RCOND REAL ROOT
C 2 ROUND RREF SAVE SCHUR
C 3 SIN SIZE SQRT SUM
C 4 SVD TRIL TRIU USER
C 5 DEBUG
C
DATA FUNN/
1 10,11,28,36, 10,29,10,23, 11,10,28,14, 12,17,10,27,
2 12,17,24,21, 12,17,24,25, 12,24,23,13, 12,24,23,19,
3 12,24,28,36, 13,14,29,36, 13,18,10,16, 13,18,10,27,
4 13,18,28,25, 14,18,16,36, 14,25,28,36, 14,33,14,12,
5 14,33,25,36, 14,34,14,36, 15,21,24,25, 17,14,28,28,
6 17,18,21,11, 18,22,10,16, 18,23,31,36, 20,27,24,23,
7 21,18,23,14, 21,24,10,13, 21,24,16,36, 21,30,36,36,
8 22,10,16,18, 23,24,27,22, 24,23,14,28, 24,27,29,17,
9 25,18,23,31, 25,21,24,29, 25,24,21,34, 25,27,18,23,
$ 25,27,24,13, 26,27,36,36, 27,10,23,13, 27,10,23,20,
1 27,10,29,36, 27,12,24,23, 27,14,10,21, 27,24,24,29,
2 27,24,30,23, 27,27,14,15, 28,10,31,14, 28,12,17,30,
3 28,18,23,36, 28,18,35,14, 28,26,27,29, 28,30,22,36,
4 28,31,13,36, 29,27,18,21, 29,27,18,30, 30,28,14,27,
5 13,14,11,30/
C
DATA FUNP/
1 221,203,507,509, 106,609,303,225, 202,102,602,505,
4 506,211,000,501, 204,606,000,213, 105,224,101,611,
7 508,503,206,104, 601,304,608,402, 302,510,214,504,
$ 604,401,607,305, 511,103,223,215, 222,107,502,212,
3 201,610,205,603, 301,614,615,605, 512/
C
IF (ID(1).EQ.0) CALL PRNTID(FUNN,FUNL-1)
IF (ID(1).EQ.0) RETURN
C
DO 10 K = 1, FUNL
IF (EQID(ID,FUNN(1,K))) GO TO 20
10 CONTINUE
FIN = 0
RETURN
C
20 FIN = MOD(FUNP(K),100)
FUN = FUNP(K)/100
IF (RHS.EQ.0 .AND. FUNP(K).EQ.606) FIN = 0
IF (RHS.EQ.0 .AND. FUNP(K).EQ.607) FIN = 0
RETURN
END
SUBROUTINE GETCH
C GET NEXT CHARACTER
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER EOL
DATA EOL/99/
L = LPT(4)
CHAR = LIN(L)
IF (CHAR .NE. EOL) LPT(4) = L + 1
RETURN
END
SUBROUTINE GETLIN
C GET A NEW LINE
INTEGER ALFA(52),ALFB(52),ALFL,CASE
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /ALFS/ ALFA,ALFB,ALFL,CASE
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER LRECL,EOL,SLASH,BSLASH,DOT,BLANK,RETU(4)
DATA EOL/99/,DOT/47/,BLANK/36/,RETU/27,14,29,30/
DATA SLASH/44/,BSLASH/45/,LRECL/80/
C
10 L = LPT(1)
11 DO 12 J = 1, LRECL
BUF(J) = ALFA(BLANK+1)
12 CONTINUE
READ(RIO,101,END=50,ERR=15) (BUF(J),J=1,LRECL)
CDC.. IF (EOF(RIO).NE.0) GO TO 50
101 FORMAT(80A1)
N = LRECL+1
15 N = N-1
IF (BUF(N) .EQ. ALFA(BLANK+1)) GO TO 15
IF (MOD(LCT(4),2) .EQ. 1) WRITE(WTE,102) (BUF(J),J=1,N)
IF (WIO .NE. 0) WRITE(WIO,102) (BUF(J),J=1,N)
102 FORMAT(1X,80A1)
C
DO 40 J = 1, N
DO 20 K = 1, ALFL
IF (BUF(J).EQ.ALFA(K) .OR. BUF(J).EQ.ALFB(K)) GO TO 30
20 CONTINUE
K = EOL+1
CALL XCHAR(BUF(J),K)
IF (K .GT. EOL) GO TO 10
IF (K .EQ. EOL) GO TO 45
IF (K .EQ. -1) L = L-1
IF (K .LE. 0) GO TO 40
C
30 K = K-1
IF (K.EQ.SLASH .AND. BUF(J+1).EQ.BUF(J)) GO TO 45
IF (K.EQ.DOT .AND. BUF(J+1).EQ.BUF(J)) GO TO 11
IF (K.EQ.BSLASH .AND. N.EQ.1) GO TO 60
LIN(L) = K
IF (L.LT.1024) L = L+1
IF (L.EQ.1024) WRITE(WTE,33) L
33 FORMAT(1X,'INPUT BUFFER LIMIT IS ',I4,' CHARACTERS.')
40 CONTINUE
45 LIN(L) = EOL
LPT(6) = L
LPT(4) = LPT(1)
LPT(3) = 0
LPT(2) = 0
LCT(1) = 0
CALL GETCH
RETURN
C
50 IF (RIO .EQ. RTE) GO TO 52
CALL PUTID(LIN(L),RETU)
L = L + 4
GO TO 45
52 CALL FILES(-1*RTE,BUF)
LIN(L) = EOL
RETURN
C
60 N = LPT(6) - LPT(1)
DO 61 I = 1, N
J = L+I-1
K = LIN(J)
BUF(I) = ALFA(K+1)
IF (CASE.EQ.1 .AND. K.LT.36) BUF(I) = ALFB(K+1)
61 CONTINUE
CALL EDIT(BUF,N)
N = N + 1
GO TO 15
END
SUBROUTINE GETSYM
C GET A SYMBOL
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER ALFA(52),ALFB(52),ALFL,CASE
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /ALFS/ ALFA,ALFB,ALFL,CASE
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
DOUBLE PRECISION SYV,S,FLOP
INTEGER BLANK,Z,DOT,D,E,PLUS,MINUS,NAME,NUM,SIGN,CHCNT,EOL
INTEGER STAR,SLASH,BSLASH,SS
DATA BLANK/36/,Z/35/,DOT/47/,D/13/,E/14/,EOL/99/,PLUS/41/
DATA MINUS/42/,NAME/1/,NUM/0/,STAR/43/,SLASH/44/,BSLASH/45/
10 IF (CHAR .NE. BLANK) GO TO 20
CALL GETCH
GO TO 10
20 LPT(2) = LPT(3)
LPT(3) = LPT(4)
IF (CHAR .LE. 9) GO TO 50
IF (CHAR .LE. Z) GO TO 30
C
C SPECIAL CHARACTER
SS = SYM
SYM = CHAR
CALL GETCH
IF (SYM .NE. DOT) GO TO 90
C
C IS DOT PART OF NUMBER OR OPERATOR
SYV = 0.0D0
IF (CHAR .LE. 9) GO TO 55
IF (CHAR.EQ.STAR .OR. CHAR.EQ.SLASH .OR. CHAR.EQ.BSLASH) GO TO 90
IF (SS.EQ.STAR .OR. SS.EQ.SLASH .OR. SS.EQ.BSLASH) GO TO 90
GO TO 55
C
C NAME
30 SYM = NAME
SYN(1) = CHAR
CHCNT = 1
40 CALL GETCH
CHCNT = CHCNT+1
IF (CHAR .GT. Z) GO TO 45
IF (CHCNT .LE. 4) SYN(CHCNT) = CHAR
GO TO 40
45 IF (CHCNT .GT. 4) GO TO 47
DO 46 I = CHCNT, 4
46 SYN(I) = BLANK
47 CONTINUE
GO TO 90
C
C NUMBER
50 CALL GETVAL(SYV)
IF (CHAR .NE. DOT) GO TO 60
CALL GETCH
55 CHCNT = LPT(4)
CALL GETVAL(S)
CHCNT = LPT(4) - CHCNT
IF (CHAR .EQ. EOL) CHCNT = CHCNT+1
SYV = SYV + S/10.0D0**CHCNT
60 IF (CHAR.NE.D .AND. CHAR.NE.E) GO TO 70
CALL GETCH
SIGN = CHAR
IF (SIGN.EQ.MINUS .OR. SIGN.EQ.PLUS) CALL GETCH
CALL GETVAL(S)
IF (SIGN .NE. MINUS) SYV = SYV*10.0D0**S
IF (SIGN .EQ. MINUS) SYV = SYV/10.0D0**S
70 STKI(VSIZE) = FLOP(SYV)
SYM = NUM
C
90 IF (CHAR .NE. BLANK) GO TO 99
CALL GETCH
GO TO 90
99 IF (DDT .NE. 1) RETURN
IF (SYM.GT.NAME .AND. SYM.LT.ALFL) WRITE(WTE,197) ALFA(SYM+1)
IF (SYM .GE. ALFL) WRITE(WTE,198)
IF (SYM .EQ. NAME) CALL PRNTID(SYN,1)
IF (SYM .EQ. NUM) WRITE(WTE,199) SYV
197 FORMAT(1X,A1)
198 FORMAT(1X,'EOL')
199 FORMAT(1X,G8.2)
RETURN
END
SUBROUTINE GETVAL(S)
DOUBLE PRECISION S
C FORM NUMERICAL VALUE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
S = 0.0D0
10 IF (CHAR .GT. 9) RETURN
S = 10.0D0*S + CHAR
CALL GETCH
GO TO 10
END
SUBROUTINE MATFN1
C
C EVALUATE FUNCTIONS INVOLVING GAUSSIAN ELIMINATION
C
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
DOUBLE PRECISION DTR(2),DTI(2),SR,SI,RCOND,T,T0,T1,FLOP,EPS,WASUM
C
IF (DDT .EQ. 1) WRITE(WTE,100) FIN
100 FORMAT(1X,'MATFN1',I4)
C
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
IF (FIN .EQ. -1) GO TO 10
IF (FIN .EQ. -2) GO TO 20
GO TO (30,40,50,60,70,80,85),FIN
C
C MATRIX RIGHT DIVISION, A/A2
10 L2 = LSTK(TOP+1)
M2 = MSTK(TOP+1)
N2 = NSTK(TOP+1)
IF (M2 .NE. N2) CALL ERROR(20)
IF (ERR .GT. 0) RETURN
IF (M*N .EQ. 1) GO TO 16
IF (N .NE. N2) CALL ERROR(11)
IF (ERR .GT. 0) RETURN
L3 = L2 + M2*N2
ERR = L3+N2 - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
CALL WGECO(STKR(L2),STKI(L2),M2,N2,BUF,RCOND,STKR(L3),STKI(L3))
IF (RCOND .EQ. 0.0D0) CALL ERROR(19)
IF (ERR .GT. 0) RETURN
T = FLOP(1.0D0 + RCOND)
IF (T.EQ.1.0D0 .AND. FUN.NE.21) WRITE(WTE,11) RCOND
IF (T.EQ.1.0D0 .AND. FUN.NE.21 .AND. WIO.NE.0) WRITE(WIO,11) RCOND
11 FORMAT(1X,'WARNING.'
$ /1X,'MATRIX IS CLOSE TO SINGULAR OR BADLY SCALED.'
$ /1X,'RESULTS MAY BE INACCURATE. RCOND =', 1PD13.4/)
IF (T.EQ.1.0D0 .AND. FUN.EQ.21) WRITE(WTE,12) RCOND
IF (T.EQ.1.0D0 .AND. FUN.EQ.21 .AND. WIO.NE.0) WRITE(WIO,12) RCOND
12 FORMAT(1X,'WARNING.'
$ /1X,'EIGENVECTORS ARE BADLY CONDITIONED.'
$ /1X,'RESULTS MAY BE INACCURATE. RCOND =', 1PD13.4/)
DO 15 I = 1, M
DO 13 J = 1, N
LS = L+I-1+(J-1)*M
LL = L3+J-1
STKR(LL) = STKR(LS)
STKI(LL) = -STKI(LS)
13 CONTINUE
CALL WGESL(STKR(L2),STKI(L2),M2,N2,BUF,STKR(L3),STKI(L3),1)
DO 14 J = 1, N
LL = L+I-1+(J-1)*M
LS = L3+J-1
STKR(LL) = STKR(LS)
STKI(LL) = -STKI(LS)
14 CONTINUE
15 CONTINUE
IF (FUN .NE. 21) GO TO 99
C
C CHECK FOR IMAGINARY ROUNDOFF IN MATRIX FUNCTIONS
SR = WASUM(N*N,STKR(L),STKR(L),1)
SI = WASUM(N*N,STKI(L),STKI(L),1)
EPS = STKR(VSIZE-4)
T = EPS*SR
IF (DDT .EQ. 18) WRITE(WTE,115) SR,SI,EPS,T
115 FORMAT(1X,'SR,SI,EPS,T',1P4D13.4)
IF (SI .LE. EPS*SR) CALL RSET(N*N,0.0D0,STKI(L),1)
GO TO 99
C
16 SR = STKR(L)
SI = STKI(L)
N = N2
M = N
MSTK(TOP) = N
NSTK(TOP) = N
CALL WCOPY(N*N,STKR(L2),STKI(L2),1,STKR(L),STKI(L),1)
GO TO 30
C
C MATRIX LEFT DIVISION A BACKSLASH A2
20 L2 = LSTK(TOP+1)
M2 = MSTK(TOP+1)
N2 = NSTK(TOP+1)
IF (M .NE. N) CALL ERROR(20)
IF (ERR .GT. 0) RETURN
IF (M2*N2 .EQ. 1) GO TO 26
L3 = L2 + M2*N2
ERR = L3+N - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
CALL WGECO(STKR(L),STKI(L),M,N,BUF,RCOND,STKR(L3),STKI(L3))
IF (RCOND .EQ. 0.0D0) CALL ERROR(19)
IF (ERR .GT. 0) RETURN
T = FLOP(1.0D0 + RCOND)
IF (T .EQ. 1.0D0) WRITE(WTE,11) RCOND
IF (T.EQ.1.0D0 .AND. WIO.NE.0) WRITE(WIO,11) RCOND
IF (M2 .NE. N) CALL ERROR(12)
IF (ERR .GT. 0) RETURN
DO 23 J = 1, N2
LJ = L2+(J-1)*M2
CALL WGESL(STKR(L),STKI(L),M,N,BUF,STKR(LJ),STKI(LJ),0)
23 CONTINUE
NSTK(TOP) = N2
CALL WCOPY(M2*N2,STKR(L2),STKI(L2),1,STKR(L),STKI(L),1)
GO TO 99
26 SR = STKR(L2)
SI = STKI(L2)
GO TO 30
C
C INV
C
30 IF (M .NE. N) CALL ERROR(20)
IF (ERR .GT. 0) RETURN
IF (DDT .EQ. 17) GO TO 32
DO 31 J = 1, N
DO 31 I = 1, N
LS = L+I-1+(J-1)*N
T0 = STKR(LS)
T1 = FLOP(1.0D0/(DFLOAT(I+J-1)))
IF (T0 .NE. T1) GO TO 32
31 CONTINUE
GO TO 72
32 L3 = L + N*N
ERR = L3+N - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
CALL WGECO(STKR(L),STKI(L),M,N,BUF,RCOND,STKR(L3),STKI(L3))
IF (RCOND .EQ. 0.0D0) CALL ERROR(19)
IF (ERR .GT. 0) RETURN
T = FLOP(1.0D0 + RCOND)
IF (T .EQ. 1.0D0) WRITE(WTE,11) RCOND
IF (T.EQ.1.0D0 .AND. WIO.NE.0) WRITE(WIO,11) RCOND
CALL WGEDI(STKR(L),STKI(L),M,N,BUF,DTR,DTI,STKR(L3),STKI(L3),1)
IF (FIN .LT. 0) CALL WSCAL(N*N,SR,SI,STKR(L),STKI(L),1)
GO TO 99
C
C DET
C
40 IF (M .NE. N) CALL ERROR(20)
IF (ERR .GT. 0) RETURN
CALL WGEFA(STKR(L),STKI(L),M,N,BUF,INFO)
CALL WGEDI(STKR(L),STKI(L),M,N,BUF,DTR,DTI,SR,SI,10)
K = IDINT(DTR(2))
KA = IABS(K)+2
T = 1.0D0
DO 41 I = 1, KA
T = T/10.0D0
IF (T .EQ. 0.0D0) GO TO 42
41 CONTINUE
STKR(L) = DTR(1)*10.D0**K
STKI(L) = DTI(1)*10.D0**K
MSTK(TOP) = 1
NSTK(TOP) = 1
GO TO 99
42 IF (DTI(1) .EQ. 0.0D0) WRITE(WTE,43) DTR(1),K
IF (DTI(1) .NE. 0.0D0) WRITE(WTE,44) DTR(1),DTI(1),K
43 FORMAT(1X,'DET = ',F7.4,7H * 10**,I4)
44 FORMAT(1X,'DET = ',F7.4,' + ',F7.4,' i ',7H * 10**,I4)
STKR(L) = DTR(1)
STKI(L) = DTI(1)
STKR(L+1) = DTR(2)
STKI(L+1) = 0.0D0
MSTK(TOP) = 1
NSTK(TOP) = 2
GO TO 99
C
C RCOND
C
50 IF (M .NE. N) CALL ERROR(20)
IF (ERR .GT. 0) RETURN
L3 = L + N*N
ERR = L3+N - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
CALL WGECO(STKR(L),STKI(L),M,N,BUF,RCOND,STKR(L3),STKI(L3))
STKR(L) = RCOND
STKI(L) = 0.0D0
MSTK(TOP) = 1
NSTK(TOP) = 1
IF (LHS .EQ. 1) GO TO 99
L = L + 1
CALL WCOPY(N,STKR(L3),STKI(L3),1,STKR(L),STKI(L),1)
TOP = TOP + 1
LSTK(TOP) = L
MSTK(TOP) = N
NSTK(TOP) = 1
GO TO 99
C
C LU
C
60 IF (M .NE. N) CALL ERROR(20)
IF (ERR .GT. 0) RETURN
CALL WGEFA(STKR(L),STKI(L),M,N,BUF,INFO)
IF (LHS .NE. 2) GO TO 99
NN = N*N
IF (TOP+1 .GE. BOT) CALL ERROR(18)
IF (ERR .GT. 0) RETURN
TOP = TOP+1
LSTK(TOP) = L + NN
MSTK(TOP) = N
NSTK(TOP) = N
ERR = L+NN+NN - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
DO 64 KB = 1, N
K = N+1-KB
DO 61 I = 1, N
LL = L+I-1+(K-1)*N
LU = LL + NN
IF (I .LE. K) STKR(LU) = STKR(LL)
IF (I .LE. K) STKI(LU) = STKI(LL)
IF (I .GT. K) STKR(LU) = 0.0D0
IF (I .GT. K) STKI(LU) = 0.0D0
IF (I .LT. K) STKR(LL) = 0.0D0
IF (I .LT. K) STKI(LL) = 0.0D0
IF (I .EQ. K) STKR(LL) = 1.0D0
IF (I .EQ. K) STKI(LL) = 0.0D0
IF (I .GT. K) STKR(LL) = -STKR(LL)
IF (I .GT. K) STKI(LL) = -STKI(LL)
61 CONTINUE
I = BUF(K)
IF (I .EQ. K) GO TO 64
LI = L+I-1+(K-1)*N
LK = L+K-1+(K-1)*N
CALL WSWAP(N-K+1,STKR(LI),STKI(LI),N,STKR(LK),STKI(LK),N)
64 CONTINUE
GO TO 99
C
C HILBERT
70 N = IDINT(STKR(L))
MSTK(TOP) = N
NSTK(TOP) = N
72 CALL HILBER(STKR(L),N,N)
CALL RSET(N*N,0.0D0,STKI(L),1)
IF (FIN .LT. 0) CALL WSCAL(N*N,SR,SI,STKR(L),STKI(L),1)
GO TO 99
C
C CHOLESKY
80 IF (M .NE. N) CALL ERROR(20)
IF (ERR .GT. 0) RETURN
CALL WPOFA(STKR(L),STKI(L),M,N,ERR)
IF (ERR .NE. 0) CALL ERROR(29)
IF (ERR .GT. 0) RETURN
DO 81 J = 1, N
LL = L+J+(J-1)*M
CALL WSET(M-J,0.0D0,0.0D0,STKR(LL),STKI(LL),1)
81 CONTINUE
GO TO 99
C
C RREF
85 IF (RHS .LT. 2) GO TO 86
TOP = TOP-1
L = LSTK(TOP)
IF (MSTK(TOP) .NE. M) CALL ERROR(5)
IF (ERR .GT. 0) RETURN
N = N + NSTK(TOP)
86 CALL RREF(STKR(L),STKI(L),M,M,N,STKR(VSIZE-4))
NSTK(TOP) = N
GO TO 99
C
99 RETURN
END
SUBROUTINE MATFN2
C
C EVALUATE ELEMENTARY FUNCTIONS AND FUNCTIONS INVOLVING
C EIGENVALUES AND EIGENVECTORS
C
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
DOUBLE PRECISION PYTHAG,ROUND,TR,TI,SR,SI,POWR,POWI,FLOP
LOGICAL HERM,SCHUR,VECT,HESS
C
IF (DDT .EQ. 1) WRITE(WTE,100) FIN
100 FORMAT(1X,'MATFN2',I4)
C
C FUNCTIONS/FIN
C ** SIN COS ATAN EXP SQRT LOG
C 0 1 2 3 4 5 6
C EIG SCHU HESS POLY ROOT
C 11 12 13 14 15
C ABS ROUN REAL IMAG CONJ
C 21 22 23 24 25
IF (FIN .NE. 0) GO TO 05
L = LSTK(TOP+1)
POWR = STKR(L)
POWI = STKI(L)
05 L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
IF (FIN .GE. 11 .AND. FIN .LE. 13) GO TO 10
IF (FIN .EQ. 14 .AND. (M.EQ.1 .OR. N.EQ.1)) GO TO 50
IF (FIN .EQ. 14) GO TO 10
IF (FIN .EQ. 15) GO TO 60
IF (FIN .GT. 20) GO TO 40
IF (M .EQ. 1 .OR. N .EQ. 1) GO TO 40
C
C EIGENVALUES AND VECTORS
10 IF (M .NE. N) CALL ERROR(20)
IF (ERR .GT. 0) RETURN
SCHUR = FIN .EQ. 12
HESS = FIN .EQ. 13
VECT = LHS.EQ.2 .OR. FIN.LT.10
NN = N*N
L2 = L + NN
LD = L2 + NN
LE = LD + N
LW = LE + N
ERR = LW+N - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
CALL WCOPY(NN,STKR(L),STKI(L),1,STKR(L2),STKI(L2),1)
C
C CHECK IF HERMITIAN
DO 15 J = 1, N
DO 15 I = 1, J
LS = L+I-1+(J-1)*N
LL = L+(I-1)*N+J-1
HERM = STKR(LL).EQ.STKR(LS) .AND. STKI(LL).EQ.-STKI(LS)
IF (.NOT. HERM) GO TO 30
15 CONTINUE
C
C HERMITIAN EIGENVALUE PROBLEM
CALL WSET(NN,0.0D0,0.0D0,STKR(L),STKI(L),1)
CALL WSET(N,1.0D0,0.0D0,STKR(L),STKI(L),N+1)
CALL WSET(N,0.0D0,0.0D0,STKI(LD),STKI(LE),1)
JOB = 0
IF (VECT) JOB = 1
CALL HTRIDI(N,N,STKR(L2),STKI(L2),STKR(LD),STKR(LE),
$ STKR(LE),STKR(LW))
IF (.NOT.HESS) CALL IMTQL2(N,N,STKR(LD),STKR(LE),STKR(L),ERR,JOB)
IF (ERR .GT. 0) CALL ERROR(24)
IF (ERR .GT. 0) RETURN
IF (JOB .NE. 0)
$ CALL HTRIBK(N,N,STKR(L2),STKI(L2),STKR(LW),N,STKR(L),STKI(L))
GO TO 31
C
C NON-HERMITIAN EIGENVALUE PROBLEM
30 CALL CORTH(N,N,1,N,STKR(L2),STKI(L2),STKR(LW),STKI(LW))
IF (.NOT.VECT .AND. HESS) GO TO 31
JOB = 0
IF (VECT) JOB = 2
IF (VECT .AND. SCHUR) JOB = 1
IF (HESS) JOB = 3
CALL COMQR3(N,N,1,N,STKR(LW),STKI(LW),STKR(L2),STKI(L2),
$ STKR(LD),STKI(LD),STKR(L),STKI(L),ERR,JOB)
IF (ERR .GT. 0) CALL ERROR(24)
IF (ERR .GT. 0) RETURN
C
C VECTORS
31 IF (.NOT.VECT) GO TO 34
IF (TOP+1 .GE. BOT) CALL ERROR(18)
IF (ERR .GT. 0) RETURN
TOP = TOP+1
LSTK(TOP) = L2
MSTK(TOP) = N
NSTK(TOP) = N
C
C DIAGONAL OF VALUES OR CANONICAL FORMS
34 IF (.NOT.VECT .AND. .NOT.SCHUR .AND. .NOT.HESS) GO TO 37
DO 36 J = 1, N
LJ = L2+(J-1)*N
IF (SCHUR .AND. (.NOT.HERM)) LJ = LJ+J
IF (HESS .AND. (.NOT.HERM)) LJ = LJ+J+1
LL = L2+J*N-LJ
CALL WSET(LL,0.0D0,0.0D0,STKR(LJ),STKI(LJ),1)
36 CONTINUE
IF (.NOT.HESS .OR. HERM)
$ CALL WCOPY(N,STKR(LD),STKI(LD),1,STKR(L2),STKI(L2),N+1)
LL = L2+1
IF (HESS .AND. HERM)
$ CALL WCOPY(N-1,STKR(LE+1),STKI(LE+1),1,STKR(LL),STKI(LL),N+1)
LL = L2+N
IF (HESS .AND. HERM)
$ CALL WCOPY(N-1,STKR(LE+1),STKI(LE+1),1,STKR(LL),STKI(LL),N+1)
IF (FIN .LT. 10) GO TO 42
IF (VECT .OR. .NOT.(SCHUR.OR.HESS)) GO TO 99
CALL WCOPY(NN,STKR(L2),STKI(L2),1,STKR(L),STKI(L),1)
GO TO 99
C
C VECTOR OF EIGENVALUES
37 IF (FIN .EQ. 14) GO TO 52
CALL WCOPY(N,STKR(LD),STKI(LD),1,STKR(L),STKI(L),1)
NSTK(TOP) = 1
GO TO 99
C
C ELEMENTARY FUNCTIONS
C FOR MATRICES.. X,D = EIG(A), FUN(A) = X*FUN(D)/X
40 INC = 1
N = M*N
L2 = L
GO TO 44
42 INC = N+1
44 DO 46 J = 1, N
LS = L2+(J-1)*INC
SR = STKR(LS)
SI = STKI(LS)
TI = 0.0D0
IF (FIN .NE. 0) GO TO 45
CALL WLOG(SR,SI,SR,SI)
CALL WMUL(SR,SI,POWR,POWI,SR,SI)
TR = DEXP(SR)*DCOS(SI)
TI = DEXP(SR)*DSIN(SI)
45 IF (FIN .EQ. 1) TR = DSIN(SR)*DCOSH(SI)
IF (FIN .EQ. 1) TI = DCOS(SR)*DSINH(SI)
IF (FIN .EQ. 2) TR = DCOS(SR)*DCOSH(SI)
IF (FIN .EQ. 2) TI = -DSIN(SR)*DSINH(SI)
IF (FIN .EQ. 3) CALL WATAN(SR,SI,TR,TI)
IF (FIN .EQ. 4) TR = DEXP(SR)*DCOS(SI)
IF (FIN .EQ. 4) TI = DEXP(SR)*DSIN(SI)
IF (FIN .EQ. 5) CALL WSQRT(SR,SI,TR,TI)
IF (FIN .EQ. 6) CALL WLOG(SR,SI,TR,TI)
IF (FIN .EQ. 21) TR = PYTHAG(SR,SI)
IF (FIN .EQ. 22) TR = ROUND(SR)
IF (FIN .EQ. 23) TR = SR
IF (FIN .EQ. 24) TR = SI
IF (FIN .EQ. 25) TR = SR
IF (FIN .EQ. 25) TI = -SI
IF (ERR .GT. 0) RETURN
STKR(LS) = FLOP(TR)
STKI(LS) = 0.0D0
IF (TI .NE. 0.0D0) STKI(LS) = FLOP(TI)
46 CONTINUE
IF (INC .EQ. 1) GO TO 99
DO 48 J = 1, N
LS = L2+(J-1)*INC
SR = STKR(LS)
SI = STKI(LS)
LS = L+(J-1)*N
LL = L2+(J-1)*N
CALL WCOPY(N,STKR(LS),STKI(LS),1,STKR(LL),STKI(LL),1)
CALL WSCAL(N,SR,SI,STKR(LS),STKI(LS),1)
48 CONTINUE
C SIGNAL MATFN1 TO DIVIDE BY EIGENVECTORS
FUN = 21
FIN = -1
TOP = TOP-1
GO TO 99
C
C POLY
C FORM POLYNOMIAL WITH GIVEN VECTOR AS ROOTS
50 N = MAX0(M,N)
LD = L+N+1
CALL WCOPY(N,STKR(L),STKI(L),1,STKR(LD),STKI(LD),1)
C
C FORM CHARACTERISTIC POLYNOMIAL
52 CALL WSET(N+1,0.0D0,0.0D0,STKR(L),STKI(L),1)
STKR(L) = 1.0D0
DO 56 J = 1, N
CALL WAXPY(J,-STKR(LD),-STKI(LD),STKR(L),STKI(L),-1,
$ STKR(L+1),STKI(L+1),-1)
LD = LD+1
56 CONTINUE
MSTK(TOP) = N+1
NSTK(TOP) = 1
GO TO 99
C
C ROOTS
60 LL = L+M*N
STKR(LL) = -1.0D0
STKI(LL) = 0.0D0
K = -1
61 K = K+1
L1 = L+K
IF (DABS(STKR(L1))+DABS(STKI(L1)) .EQ. 0.0D0) GO TO 61
N = MAX0(M*N - K-1, 0)
IF (N .LE. 0) GO TO 65
L2 = L1+N+1
LW = L2+N*N
ERR = LW+N - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
CALL WSET(N*N+N,0.0D0,0.0D0,STKR(L2),STKI(L2),1)
DO 64 J = 1, N
LL = L2+J+(J-1)*N
STKR(LL) = 1.0D0
LS = L1+J
LL = L2+(J-1)*N
CALL WDIV(-STKR(LS),-STKI(LS),STKR(L1),STKI(L1),
$ STKR(LL),STKI(LL))
IF (ERR .GT. 0) RETURN
64 CONTINUE
CALL COMQR3(N,N,1,N,STKR(LW),STKI(LW),STKR(L2),STKI(L2),
$ STKR(L),STKI(L),TR,TI,ERR,0)
IF (ERR .GT. 0) CALL ERROR(24)
IF (ERR .GT. 0) RETURN
65 MSTK(TOP) = N
NSTK(TOP) = 1
GO TO 99
99 RETURN
END
SUBROUTINE MATFN3
C
C EVALUATE FUNCTIONS INVOLVING SINGULAR VALUE DECOMPOSITION
C
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
LOGICAL FRO,INF
DOUBLE PRECISION P,S,T,TOL,EPS
DOUBLE PRECISION WDOTCR,WDOTCI,PYTHAG,WNRM2,WASUM,FLOP
C
IF (DDT .EQ. 1) WRITE(WTE,100) FIN
100 FORMAT(1X,'MATFN3',I4)
C
IF (FIN.EQ.1 .AND. RHS.EQ.2) TOP = TOP-1
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
MN = M*N
GO TO (50,70,10,30,70), FIN
C
C COND
C
10 LD = L + M*N
L1 = LD + MIN0(M+1,N)
L2 = L1 + N
ERR = L2+MIN0(M,N) - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
CALL WSVDC(STKR(L),STKI(L),M,M,N,STKR(LD),STKI(LD),
$ STKR(L1),STKI(L1),T,T,1,T,T,1,STKR(L2),STKI(L2),
$ 0,ERR)
IF (ERR .NE. 0) CALL ERROR(24)
IF (ERR .GT. 0) RETURN
S = STKR(LD)
LD = LD + MIN0(M,N) - 1
T = STKR(LD)
IF (T .EQ. 0.0D0) GO TO 13
STKR(L) = FLOP(S/T)
STKI(L) = 0.0D0
MSTK(TOP) = 1
NSTK(TOP) = 1
GO TO 99
13 WRITE(WTE,14)
IF (WIO .NE. 0) WRITE(WIO,14)
14 FORMAT(1X,'CONDITION IS INFINITE')
MSTK(TOP) = 0
GO TO 99
C
C NORM
C
30 P = 2.0D0
INF = .FALSE.
IF (RHS .NE. 2) GO TO 31
FRO = IDINT(STKR(L)).EQ.15 .AND. MN.GT.1
INF = IDINT(STKR(L)).EQ.18 .AND. MN.GT.1
IF (.NOT. FRO) P = STKR(L)
TOP = TOP-1
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
MN = M*N
IF (FRO) M = MN
IF (FRO) N = 1
31 IF (M .GT. 1 .AND. N .GT. 1) GO TO 40
IF (P .EQ. 1.0D0) GO TO 36
IF (P .EQ. 2.0D0) GO TO 38
I = IWAMAX(MN,STKR(L),STKI(L),1) + L - 1
S = DABS(STKR(I)) + DABS(STKI(I))
IF (INF .OR. S .EQ. 0.0D0) GO TO 49
T = 0.0D0
DO 33 I = 1, MN
LS = L+I-1
T = FLOP(T + (PYTHAG(STKR(LS),STKI(LS))/S)**P)
33 CONTINUE
IF (P .NE. 0.0D0) P = 1.0D0/P
S = FLOP(S*T**P)
GO TO 49
36 S = WASUM(MN,STKR(L),STKI(L),1)
GO TO 49
38 S = WNRM2(MN,STKR(L),STKI(L),1)
GO TO 49
C
C MATRIX NORM
C
40 IF (INF) GO TO 43
IF (P .EQ. 1.0D0) GO TO 46
IF (P .NE. 2.0D0) CALL ERROR(23)
IF (ERR .GT. 0) RETURN
LD = L + M*N
L1 = LD + MIN0(M+1,N)
L2 = L1 + N
ERR = L2+MIN0(M,N) - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
CALL WSVDC(STKR(L),STKI(L),M,M,N,STKR(LD),STKI(LD),
$ STKR(L1),STKI(L1),T,T,1,T,T,1,STKR(L2),STKI(L2),
$ 0,ERR)
IF (ERR .NE. 0) CALL ERROR(24)
IF (ERR .GT. 0) RETURN
S = STKR(LD)
GO TO 49
43 S = 0.0D0
DO 45 I = 1, M
LI = L+I-1
T = WASUM(N,STKR(LI),STKI(LI),M)
S = DMAX1(S,T)
45 CONTINUE
GO TO 49
46 S = 0.0D0
DO 48 J = 1, N
LJ = L+(J-1)*M
T = WASUM(M,STKR(LJ),STKI(LJ),1)
S = DMAX1(S,T)
48 CONTINUE
GO TO 49
49 STKR(L) = S
STKI(L) = 0.0D0
MSTK(TOP) = 1
NSTK(TOP) = 1
GO TO 99
C
C SVD
C
50 IF (LHS .NE. 3) GO TO 52
K = M
IF (RHS .EQ. 2) K = MIN0(M,N)
LU = L + M*N
LD = LU + M*K
LV = LD + K*N
L1 = LV + N*N
L2 = L1 + N
ERR = L2+MIN0(M,N) - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
JOB = 11
IF (RHS .EQ. 2) JOB = 21
CALL WSVDC(STKR(L),STKI(L),M,M,N,STKR(LD),STKI(LD),
$ STKR(L1),STKI(L1),STKR(LU),STKI(LU),M,STKR(LV),STKI(LV),
$ N,STKR(L2),STKI(L2),JOB,ERR)
DO 51 JB = 1, N
DO 51 I = 1, K
J = N+1-JB
LL = LD+I-1+(J-1)*K
IF (I.NE.J) STKR(LL) = 0.0D0
STKI(LL) = 0.0D0
LS = LD+I-1
IF (I.EQ.J) STKR(LL) = STKR(LS)
LS = L1+I-1
IF (ERR.NE.0 .AND. I.EQ.J-1) STKR(LL) = STKR(LS)
51 CONTINUE
IF (ERR .NE. 0) CALL ERROR(24)
ERR = 0
CALL WCOPY(M*K+K*N+N*N,STKR(LU),STKI(LU),1,STKR(L),STKI(L),1)
MSTK(TOP) = M
NSTK(TOP) = K
IF (TOP+1 .GE. BOT) CALL ERROR(18)
IF (ERR .GT. 0) RETURN
TOP = TOP+1
LSTK(TOP) = L + M*K
MSTK(TOP) = K
NSTK(TOP) = N
IF (TOP+1 .GE. BOT) CALL ERROR(18)
IF (ERR .GT. 0) RETURN
TOP = TOP+1
LSTK(TOP) = L + M*K + K*N
MSTK(TOP) = N
NSTK(TOP) = N
GO TO 99
C
52 LD = L + M*N
L1 = LD + MIN0(M+1,N)
L2 = L1 + N
ERR = L2+MIN0(M,N) - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
CALL WSVDC(STKR(L),STKI(L),M,M,N,STKR(LD),STKI(LD),
$ STKR(L1),STKI(L1),T,T,1,T,T,1,STKR(L2),STKI(L2),
$ 0,ERR)
IF (ERR .NE. 0) CALL ERROR(24)
IF (ERR .GT. 0) RETURN
K = MIN0(M,N)
CALL WCOPY(K,STKR(LD),STKI(LD),1,STKR(L),STKI(L),1)
MSTK(TOP) = K
NSTK(TOP) = 1
GO TO 99
C
C PINV AND RANK
C
70 TOL = -1.0D0
IF (RHS .NE. 2) GO TO 71
TOL = STKR(L)
TOP = TOP-1
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
71 LU = L + M*N
LD = LU + M*M
IF (FIN .EQ. 5) LD = L + M*N
LV = LD + M*N
L1 = LV + N*N
IF (FIN .EQ. 5) L1 = LD + N
L2 = L1 + N
ERR = L2+MIN0(M,N) - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
IF (FIN .EQ. 2) JOB = 11
IF (FIN .EQ. 5) JOB = 0
CALL WSVDC(STKR(L),STKI(L),M,M,N,STKR(LD),STKI(LD),
$ STKR(L1),STKI(L1),STKR(LU),STKI(LU),M,STKR(LV),STKI(LV),
$ N,STKR(L2),STKI(L2),JOB,ERR)
IF (ERR .NE. 0) CALL ERROR(24)
IF (ERR .GT. 0) RETURN
EPS = STKR(VSIZE-4)
IF (TOL .LT. 0.0D0) TOL = FLOP(DFLOAT(MAX0(M,N))*EPS*STKR(LD))
MN = MIN0(M,N)
K = 0
DO 72 J = 1, MN
LS = LD+J-1
S = STKR(LS)
IF (S .LE. TOL) GO TO 73
K = J
LL = LV+(J-1)*N
IF (FIN .EQ. 2) CALL WRSCAL(N,1.0D0/S,STKR(LL),STKI(LL),1)
72 CONTINUE
73 IF (FIN .EQ. 5) GO TO 78
DO 76 J = 1, M
DO 76 I = 1, N
LL = L+I-1+(J-1)*N
L1 = LV+I-1
L2 = LU+J-1
STKR(LL) = WDOTCR(K,STKR(L2),STKI(L2),M,STKR(L1),STKI(L1),N)
STKI(LL) = WDOTCI(K,STKR(L2),STKI(L2),M,STKR(L1),STKI(L1),N)
76 CONTINUE
MSTK(TOP) = N
NSTK(TOP) = M
GO TO 99
78 STKR(L) = DFLOAT(K)
STKI(L) = 0.0D0
MSTK(TOP) = 1
NSTK(TOP) = 1
GO TO 99
C
99 RETURN
END
SUBROUTINE MATFN4
C
C EVALUATE FUNCTIONS INVOLVING QR DECOMPOSITION (LEAST SQUARES)
C
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
DOUBLE PRECISION T,TOL,EPS,FLOP
INTEGER QUOTE
DATA QUOTE/49/
C
IF (DDT .EQ. 1) WRITE(WTE,100) FIN
100 FORMAT(1X,'MATFN4',I4)
C
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
IF (FIN .EQ. -1) GO TO 10
IF (FIN .EQ. -2) GO TO 20
GO TO 40
C
C RECTANGULAR MATRIX RIGHT DIVISION, A/A2
10 L2 = LSTK(TOP+1)
M2 = MSTK(TOP+1)
N2 = NSTK(TOP+1)
TOP = TOP + 1
IF (N.GT.1 .AND. N.NE.N2) CALL ERROR(11)
IF (ERR .GT. 0) RETURN
CALL STACK1(QUOTE)
IF (ERR .GT. 0) RETURN
LL = L2+M2*N2
CALL WCOPY(M*N,STKR(L),STKI(L),1,STKR(LL),STKI(LL),1)
CALL WCOPY(M*N+M2*N2,STKR(L2),STKI(L2),1,STKR(L),STKI(L),1)
LSTK(TOP) = L+M2*N2
MSTK(TOP) = M
NSTK(TOP) = N
CALL STACK1(QUOTE)
IF (ERR .GT. 0) RETURN
TOP = TOP - 1
M = N2
N = M2
GO TO 20
C
C RECTANGULAR MATRIX LEFT DIVISION A BACKSLASH A2
C
20 L2 = LSTK(TOP+1)
M2 = MSTK(TOP+1)
N2 = NSTK(TOP+1)
IF (M2*N2 .GT. 1) GO TO 21
M2 = M
N2 = M
ERR = L2+M*M - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
CALL WSET(M*M-1,0.0D0,0.0D0,STKR(L2+1),STKI(L2+1),1)
CALL WCOPY(M,STKR(L2),STKI(L2),0,STKR(L2),STKI(L2),M+1)
21 IF (M2 .NE. M) CALL ERROR(12)
IF (ERR .GT. 0) RETURN
L3 = L2 + MAX0(M,N)*N2
L4 = L3 + N
ERR = L4 + N - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
IF (M .GT. N) GO TO 23
DO 22 JB = 1, N2
J = N+1-JB
LS = L2 + (J-1)*M
LL = L2 + (J-1)*N
CALL WCOPY(M,STKR(LS),STKI(LS),-1,STKR(LL),STKI(LL),-1)
22 CONTINUE
23 DO 24 J = 1, N
BUF(J) = 0
24 CONTINUE
CALL WQRDC(STKR(L),STKI(L),M,M,N,STKR(L4),STKI(L4),
$ BUF,STKR(L3),STKI(L3),1)
K = 0
EPS = STKR(VSIZE-4)
T = DABS(STKR(L))+DABS(STKI(L))
TOL = FLOP(DFLOAT(MAX0(M,N))*EPS*T)
MN = MIN0(M,N)
DO 27 J = 1, MN
LS = L+J-1+(J-1)*M
T = DABS(STKR(LS)) + DABS(STKI(LS))
IF (T .GT. TOL) K = J
27 CONTINUE
IF (K .LT. MN) WRITE(WTE,28) K,TOL
IF (K.LT.MN .AND. WIO.NE.0) WRITE(WIO,28) K,TOL
28 FORMAT(1X,'RANK DEFICIENT, RANK =',I4,', TOL =',1PD13.4)
MN = MAX0(M,N)
DO 29 J = 1, N2
LS = L2+(J-1)*MN
CALL WQRSL(STKR(L),STKI(L),M,M,K,STKR(L4),STKI(L4),
$ STKR(LS),STKI(LS),T,T,STKR(LS),STKI(LS),
$ STKR(LS),STKI(LS),T,T,T,T,100,INFO)
LL = LS+K
CALL WSET(N-K,0.0D0,0.0D0,STKR(LL),STKI(LL),1)
29 CONTINUE
DO 31 J = 1, N
BUF(J) = -BUF(J)
31 CONTINUE
DO 35 J = 1, N
IF (BUF(J) .GT. 0) GO TO 35
K = -BUF(J)
BUF(J) = K
33 CONTINUE
IF (K .EQ. J) GO TO 34
LS = L2+J-1
LL = L2+K-1
CALL WSWAP(N2,STKR(LS),STKI(LS),MN,STKR(LL),STKI(LL),MN)
BUF(K) = -BUF(K)
K = BUF(K)
GO TO 33
34 CONTINUE
35 CONTINUE
DO 36 J = 1, N2
LS = L2+(J-1)*MN
LL = L+(J-1)*N
CALL WCOPY(N,STKR(LS),STKI(LS),1,STKR(LL),STKI(LL),1)
36 CONTINUE
MSTK(TOP) = N
NSTK(TOP) = N2
IF (FIN .EQ. -1) CALL STACK1(QUOTE)
IF (ERR .GT. 0) RETURN
GO TO 99
C
C QR
C
40 MM = MAX0(M,N)
LS = L + MM*MM
IF (LHS.EQ.1 .AND. FIN.EQ.1) LS = L
LE = LS + M*N
L4 = LE + MM
ERR = L4+MM - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
IF (LS.NE.L) CALL WCOPY(M*N,STKR(L),STKI(L),1,STKR(LS),STKI(LS),1)
JOB = 1
IF (LHS.LT.3) JOB = 0
DO 42 J = 1, N
BUF(J) = 0
42 CONTINUE
CALL WQRDC(STKR(LS),STKI(LS),M,M,N,STKR(L4),STKI(L4),
$ BUF,STKR(LE),STKI(LE),JOB)
IF (LHS.EQ.1 .AND. FIN.EQ.1) GO TO 99
CALL WSET(M*M,0.0D0,0.0D0,STKR(L),STKI(L),1)
CALL WSET(M,1.0D0,0.0D0,STKR(L),STKI(L),M+1)
DO 43 J = 1, M
LL = L+(J-1)*M
CALL WQRSL(STKR(LS),STKI(LS),M,M,N,STKR(L4),STKI(L4),
$ STKR(LL),STKI(LL),STKR(LL),STKI(LL),T,T,
$ T,T,T,T,T,T,10000,INFO)
43 CONTINUE
IF (FIN .EQ. 2) GO TO 99
NSTK(TOP) = M
DO 45 J = 1, N
LL = LS+J+(J-1)*M
CALL WSET(M-J,0.0D0,0.0D0,STKR(LL),STKI(LL),1)
45 CONTINUE
IF (TOP+1 .GE. BOT) CALL ERROR(18)
IF (ERR .GT. 0) RETURN
TOP = TOP+1
LSTK(TOP) = LS
MSTK(TOP) = M
NSTK(TOP) = N
IF (LHS .EQ. 2) GO TO 99
CALL WSET(N*N,0.0D0,0.0D0,STKR(LE),STKI(LE),1)
DO 47 J = 1, N
LL = LE+BUF(J)-1+(J-1)*N
STKR(LL) = 1.0D0
47 CONTINUE
IF (TOP+1 .GE. BOT) CALL ERROR(18)
IF (ERR .GT. 0) RETURN
TOP = TOP+1
LSTK(TOP) = LE
MSTK(TOP) = N
NSTK(TOP) = N
GO TO 99
C
99 RETURN
END
SUBROUTINE MATFN5
C
C FILE HANDLING AND OTHER I/O
C
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER ALFA(52),ALFB(52),ALFL,CASE
INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /ALFS/ ALFA,ALFB,ALFL,CASE
COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER EOL,CH,BLANK,FLAG,TOP2,PLUS,MINUS,QUOTE,SEMI,LRAT,MRAT
INTEGER ID(4)
DOUBLE PRECISION EPS,B,S,T,FLOP,WASUM
LOGICAL TEXT
DATA EOL/99/,BLANK/36/,PLUS/41/,MINUS/42/,QUOTE/49/,SEMI/39/
DATA LRAT/5/,MRAT/100/
C
IF (DDT .EQ. 1) WRITE(WTE,100) FIN
100 FORMAT(1X,'MATFN5',I4)
C FUNCTIONS/FIN
C EXEC SAVE LOAD PRIN DIAR DISP BASE LINE CHAR PLOT RAT DEBU
C 1 2 3 4 5 6 7 8 9 10 11 12
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
IF (FIN .GT. 5) GO TO 15
C
C CONVERT FILE NAME
MN = M*N
FLAG = 3
IF (SYM .EQ. SEMI) FLAG = 0
IF (RHS .LT. 2) GO TO 12
FLAG = IDINT(STKR(L))
TOP2 = TOP
TOP = TOP-1
L = LSTK(TOP)
MN = MSTK(TOP)*NSTK(TOP)
12 LUN = -1
IF (MN.EQ.1 .AND. STKR(L).LT.10.0D0) LUN = IDINT(STKR(L))
IF (LUN .GE. 0) GO TO 15
DO 14 J = 1, 32
LS = L+J-1
IF (J .LE. MN) CH = IDINT(STKR(LS))
IF (J .GT. MN) CH = BLANK
IF (CH.LT.0 .OR. CH.GE.ALFL) CALL ERROR(38)
IF (ERR .GT. 0) RETURN
IF (CASE .EQ. 0) BUF(J) = ALFA(CH+1)
IF (CASE .EQ. 1) BUF(J) = ALFB(CH+1)
14 CONTINUE
C
15 GO TO (20,30,35,25,27,60,65,70,50,80,40,95),FIN
C
C EXEC
20 IF (LUN .EQ. 0) GO TO 23
K = LPT(6)
LIN(K+1) = LPT(1)
LIN(K+2) = LPT(3)
LIN(K+3) = LPT(6)
LIN(K+4) = PTZ
LIN(K+5) = RIO
LIN(K+6) = LCT(4)
LPT(1) = K + 7
LCT(4) = FLAG
PTZ = PT - 4
IF (RIO .EQ. RTE) RIO = 12
RIO = RIO + 1
IF (LUN .GT. 0) RIO = LUN
IF (LUN .LT. 0) CALL FILES(RIO,BUF)
IF (FLAG .GE. 4) WRITE(WTE,22)
22 FORMAT(1X,'PAUSE MODE. ENTER BLANK LINES.')
SYM = EOL
MSTK(TOP) = 0
GO TO 99
C
C EXEC(0)
23 RIO = RTE
ERR = 99
GO TO 99
C
C PRINT
25 K = WTE
WTE = LUN
IF (LUN .LT. 0) WTE = 7
IF (LUN .LT. 0) CALL FILES(WTE,BUF)
L = LCT(2)
LCT(2) = 9999
IF (RHS .GT. 1) CALL PRINT(SYN,TOP2)
LCT(2) = L
WTE = K
MSTK(TOP) = 0
GO TO 99
C
C DIARY
27 WIO = LUN
IF (LUN .LT. 0) WIO = 8
IF (LUN .LT. 0) CALL FILES(WIO,BUF)
MSTK(TOP) = 0
GO TO 99
C
C SAVE
30 IF (LUN .LT. 0) LUNIT = 1
IF (LUN .LT. 0) CALL FILES(LUNIT,BUF)
IF (LUN .GT. 0) LUNIT = LUN
K = LSIZE-4
IF (K .LT. BOT) K = LSIZE
IF (RHS .EQ. 2) K = TOP2
IF (RHS .EQ. 2) CALL PUTID(IDSTK(1,K),SYN)
32 L = LSTK(K)
M = MSTK(K)
N = NSTK(K)
DO 34 I = 1, 4
J = IDSTK(I,K)+1
BUF(I) = ALFA(J)
34 CONTINUE
IMG = 0
IF (WASUM(M*N,STKI(L),STKI(L),1) .NE. 0.0D0) IMG = 1
IF(FE .EQ. 0)CALL SAVLOD(LUNIT,BUF,M,N,IMG,0,STKR(L),STKI(L))
K = K-1
IF (K .GE. BOT) GO TO 32
CALL FILES(-LUNIT,BUF)
MSTK(TOP) = 0
GO TO 99
C
C LOAD
35 IF (LUN .LT. 0) LUNIT = 2
IF (LUN .LT. 0) CALL FILES(LUNIT,BUF)
IF (LUN .GT. 0) LUNIT = LUN
36 JOB = LSTK(BOT) - L
IF(FE .EQ. 0)
+CALL SAVLOD(LUNIT,ID,MSTK(TOP),NSTK(TOP),IMG,JOB,STKR(L),STKI(L))
MN = MSTK(TOP)*NSTK(TOP)
IF (MN .EQ. 0) GO TO 39
IF (IMG .EQ. 0) CALL RSET(MN,0.0D0,STKI(L),1)
DO 38 I = 1, 4
J = 0
37 J = J+1
IF (ID(I).NE.ALFA(J) .AND. J.LE.BLANK) GO TO 37
ID(I) = J-1
38 CONTINUE
SYM = SEMI
RHS = 0
CALL STACKP(ID)
TOP = TOP + 1
GO TO 36
39 CALL FILES(-LUNIT,BUF)
MSTK(TOP) = 0
GO TO 99
C
C RAT
40 IF (RHS .EQ. 2) GO TO 44
MN = M*N
L2 = L
IF (LHS .EQ. 2) L2 = L + MN
LW = L2 + MN
ERR = LW + LRAT - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
IF (LHS .EQ. 2) TOP = TOP + 1
LSTK(TOP) = L2
MSTK(TOP) = M
NSTK(TOP) = N
CALL RSET(LHS*MN,0.0D0,STKI(L),1)
DO 42 I = 1, MN
CALL RAT(STKR(L),LRAT,MRAT,S,T,STKR(LW))
STKR(L) = S
STKR(L2) = T
IF (LHS .EQ. 1) STKR(L) = FLOP(S/T)
L = L + 1
L2 = L2 + 1
42 CONTINUE
GO TO 99
44 MRAT = IDINT(STKR(L))
LRAT = IDINT(STKR(L-1))
TOP = TOP - 1
MSTK(TOP) = 0
GO TO 99
C
C CHAR
50 K = IABS(IDINT(STKR(L)))
IF (M*N.NE.1 .OR. K.GE.ALFL) CALL ERROR(36)
IF (ERR .GT. 0) RETURN
CH = ALFA(K+1)
IF (STKR(L) .LT. 0.0D0) CH = ALFB(K+1)
WRITE(WTE,51) CH
51 FORMAT(1X,'REPLACE CHARACTER ',A1)
READ(RTE,52) CH
52 FORMAT(A1)
IF (STKR(L) .GE. 0.0D0) ALFA(K+1) = CH
IF (STKR(L) .LT. 0.0D0) ALFB(K+1) = CH
MSTK(TOP) = 0
GO TO 99
C
C DISP
60 WRITE(WTE,61)
IF (WIO .NE. 0) WRITE(WIO,61)
61 FORMAT(1X,80A1)
IF (RHS .EQ. 2) GO TO 65
MN = M*N
TEXT = .TRUE.
DO 62 I = 1, MN
LS = L+I-1
CH = IDINT(STKR(LS))
TEXT = TEXT .AND. (CH.GE.0) .AND. (CH.LT.ALFL)
TEXT = TEXT .AND. (DFLOAT(CH).EQ.STKR(LS))
62 CONTINUE
DO 64 I = 1, M
DO 63 J = 1, N
LS = L+I-1+(J-1)*M
IF (STKR(LS) .EQ. 0.0D0) CH = BLANK
IF (STKR(LS) .GT. 0.0D0) CH = PLUS
IF (STKR(LS) .LT. 0.0D0) CH = MINUS
IF (TEXT) CH = IDINT(STKR(LS))
BUF(J) = ALFA(CH+1)
63 CONTINUE
WRITE(WTE,61) (BUF(J),J=1,N)
IF (WIO .NE. 0) WRITE(WIO,61) (BUF(J),J=1,N)
64 CONTINUE
MSTK(TOP) = 0
GO TO 99
C
C BASE
65 IF (RHS .NE. 2) CALL ERROR(39)
IF (STKR(L) .LE. 1.0D0) CALL ERROR(36)
IF (ERR .GT. 0) RETURN
B = STKR(L)
L2 = L
TOP = TOP-1
RHS = 1
L = LSTK(TOP)
M = MSTK(TOP)*NSTK(TOP)
EPS = STKR(VSIZE-4)
DO 66 I = 1, M
LS = L2+(I-1)*N
LL = L+I-1
CALL BASE(STKR(LL),B,EPS,STKR(LS),N)
66 CONTINUE
CALL RSET(M*N,0.0D0,STKI(L2),1)
CALL WCOPY(M*N,STKR(L2),STKI(L2),1,STKR(L),STKI(L),1)
MSTK(TOP) = N
NSTK(TOP) = M
CALL STACK1(QUOTE)
IF (FIN .EQ. 6) GO TO 60
GO TO 99
C
C LINES
70 LCT(2) = IDINT(STKR(L))
MSTK(TOP) = 0
GO TO 99
C
C PLOT
80 IF (RHS .GE. 2) GO TO 82
N = M*N
DO 81 I = 1, N
LL = L+I-1
STKI(LL) = DFLOAT(I)
81 CONTINUE
CALL PLOT(WTE,STKI(L),STKR(L),N,T,0,BUF)
IF (WIO .NE. 0) CALL PLOT(WIO,STKI(L),STKR(L),N,T,0,BUF)
MSTK(TOP) = 0
GO TO 99
82 IF (RHS .EQ. 2) K = 0
IF (RHS .EQ. 3) K = M*N
IF (RHS .GT. 3) K = RHS - 2
TOP = TOP - (RHS - 1)
N = MSTK(TOP)*NSTK(TOP)
IF (MSTK(TOP+1)*NSTK(TOP+1) .NE. N) CALL ERROR(5)
IF (ERR .GT. 0) RETURN
LX = LSTK(TOP)
LY = LSTK(TOP+1)
IF (RHS .GT. 3) L = LSTK(TOP+2)
CALL PLOT(WTE,STKR(LX),STKR(LY),N,STKR(L),K,BUF)
IF (WIO .NE. 0) CALL PLOT(WIO,STKR(LX),STKR(LY),N,STKR(L),K,BUF)
MSTK(TOP) = 0
GO TO 99
C
C DEBUG
95 DDT = IDINT(STKR(L))
WRITE(WTE,96) DDT
96 FORMAT(1X,'DEBUG ',I4)
MSTK(TOP) = 0
GO TO 99
C
99 RETURN
END
SUBROUTINE MATFN6
C
C EVALUATE UTILITY FUNCTIONS
C
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER SEMI,ID(4),UNIFOR(4),NORMAL(4),SEED(4)
DOUBLE PRECISION EPS0,EPS,S,SR,SI,T
DOUBLE PRECISION FLOP,URAND
LOGICAL EQID
DATA SEMI/39/
DATA UNIFOR/30,23,18,15/,NORMAL/23,24,27,22/,SEED/28,14,14,13/
C
IF (DDT .EQ. 1) WRITE(WTE,100) FIN
100 FORMAT(1X,'MATFN6',I4)
C FUNCTIONS/FIN
C MAGI DIAG SUM PROD USER EYE RAND ONES CHOP SIZE KRON TRIL TRIU
C 1 2 3 4 5 6 7 8 9 10 11-13 14 15
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
GO TO (75,80,65,67,70,90,90,90,60,77,50,50,50,80,80),FIN
C
C KRONECKER PRODUCT
50 IF (RHS .NE. 2) CALL ERROR(39)
IF (ERR .GT. 0) RETURN
TOP = TOP - 1
L = LSTK(TOP)
MA = MSTK(TOP)
NA = NSTK(TOP)
LA = L + MAX0(M*N*MA*NA,M*N+MA*NA)
LB = LA + MA*NA
ERR = LB + M*N - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
C MOVE A AND B ABOVE RESULT
CALL WCOPY(MA*NA+M*N,STKR(L),STKI(L),1,STKR(LA),STKI(LA),1)
DO 54 JA = 1, NA
DO 53 J = 1, N
LJ = LB + (J-1)*M
DO 52 IA = 1, MA
C GET J-TH COLUMN OF B
CALL WCOPY(M,STKR(LJ),STKI(LJ),1,STKR(L),STKI(L),1)
C ADDRESS OF A(IA,JA)
LS = LA + IA-1 + (JA-1)*MA
DO 51 I = 1, M
C A(IA,JA) OP B(I,J)
IF (FIN .EQ. 11) CALL WMUL(STKR(LS),STKI(LS),
$ STKR(L),STKI(L),STKR(L),STKI(L))
IF (FIN .EQ. 12) CALL WDIV(STKR(LS),STKI(LS),
$ STKR(L),STKI(L),STKR(L),STKI(L))
IF (FIN .EQ. 13) CALL WDIV(STKR(L),STKI(L),
$ STKR(LS),STKI(LS),STKR(L),STKI(L))
IF (ERR .GT. 0) RETURN
L = L + 1
51 CONTINUE
52 CONTINUE
53 CONTINUE
54 CONTINUE
MSTK(TOP) = M*MA
NSTK(TOP) = N*NA
GO TO 99
C
C CHOP
60 EPS0 = 1.0D0
61 EPS0 = EPS0/2.0D0
T = FLOP(1.0D0 + EPS0)
IF (T .GT. 1.0D0) GO TO 61
EPS0 = 2.0D0*EPS0
FLP(2) = IDINT(STKR(L))
IF (SYM .NE. SEMI) WRITE(WTE,62) FLP(2)
62 FORMAT(/1X,'CHOP ',I2,' PLACES.')
EPS = 1.0D0
63 EPS = EPS/2.0D0
T = FLOP(1.0D0 + EPS)
IF (T .GT. 1.0D0) GO TO 63
EPS = 2.0D0*EPS
T = STKR(VSIZE-4)
IF (T.LT.EPS .OR. T.EQ.EPS0) STKR(VSIZE-4) = EPS
MSTK(TOP) = 0
GO TO 99
C
C SUM
65 SR = 0.0D0
SI = 0.0D0
MN = M*N
DO 66 I = 1, MN
LS = L+I-1
SR = FLOP(SR+STKR(LS))
SI = FLOP(SI+STKI(LS))
66 CONTINUE
GO TO 69
C
C PROD
67 SR = 1.0D0
SI = 0.0D0
MN = M*N
DO 68 I = 1, MN
LS = L+I-1
CALL WMUL(STKR(LS),STKI(LS),SR,SI,SR,SI)
68 CONTINUE
69 STKR(L) = SR
STKI(L) = SI
MSTK(TOP) = 1
NSTK(TOP) = 1
GO TO 99
C
C USER
70 S = 0.0D0
T = 0.0D0
IF (RHS .LT. 2) GO TO 72
IF (RHS .LT. 3) GO TO 71
T = STKR(L)
TOP = TOP-1
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
71 S = STKR(L)
TOP = TOP-1
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
72 CALL USER(STKR(L),M,N,S,T)
CALL RSET(M*N,0.0D0,STKI(L),1)
MSTK(TOP) = M
NSTK(TOP) = N
GO TO 99
C
C MAGIC
75 N = MAX0(IDINT(STKR(L)),0)
IF (N .EQ. 2) N = 0
IF (N .GT. 0) CALL MAGIC(STKR(L),N,N)
CALL RSET(N*N,0.0D0,STKI(L),1)
MSTK(TOP) = N
NSTK(TOP) = N
GO TO 99
C
C SIZE
77 STKR(L) = M
STKR(L+1) = N
STKI(L) = 0.0D0
STKI(L+1) = 0.0D0
MSTK(TOP) = 1
NSTK(TOP) = 2
IF (LHS .EQ. 1) GO TO 99
NSTK(TOP) = 1
TOP = TOP + 1
LSTK(TOP) = L+1
MSTK(TOP) = 1
NSTK(TOP) = 1
GO TO 99
C
C DIAG, TRIU, TRIL
80 K = 0
IF (RHS .NE. 2) GO TO 81
K = IDINT(STKR(L))
TOP = TOP-1
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
81 IF (FIN .GE. 14) GO TO 85
IF (M .EQ. 1 .OR. N .EQ. 1) GO TO 83
IF (K.GE.0) MN=MIN0(M,N-K)
IF (K.LT.0) MN=MIN0(M+K,N)
MSTK(TOP) = MAX0(MN,0)
NSTK(TOP) = 1
IF (MN .LE. 0) GO TO 99
DO 82 I = 1, MN
IF (K.GE.0) LS = L+(I-1)+(I+K-1)*M
IF (K.LT.0) LS = L+(I-K-1)+(I-1)*M
LL = L+I-1
STKR(LL) = STKR(LS)
STKI(LL) = STKI(LS)
82 CONTINUE
GO TO 99
83 N = MAX0(M,N)+IABS(K)
ERR = L+N*N - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
MSTK(TOP) = N
NSTK(TOP) = N
DO 84 JB = 1, N
DO 84 IB = 1, N
J = N+1-JB
I = N+1-IB
SR = 0.0D0
SI = 0.0D0
IF (K.GE.0) LS = L+I-1
IF (K.LT.0) LS = L+J-1
LL = L+I-1+(J-1)*N
IF (J-I .EQ. K) SR = STKR(LS)
IF (J-I .EQ. K) SI = STKI(LS)
STKR(LL) = SR
STKI(LL) = SI
84 CONTINUE
GO TO 99
C
C TRIL, TRIU
85 DO 87 J = 1, N
LD = L + J - K - 1 + (J-1)*M
IF (FIN .EQ. 14) LL = J - K - 1
IF (FIN .EQ. 14) LS = LD - LL
IF (FIN .EQ. 15) LL = M - J + K
IF (FIN .EQ. 15) LS = LD + 1
IF (LL .GT. 0) CALL WSET(LL,0.0D0,0.0D0,STKR(LS),STKI(LS),1)
87 CONTINUE
GO TO 99
C
C EYE, RAND, ONES
90 IF (M.GT.1 .OR. RHS.EQ.0) GO TO 94
IF (RHS .NE. 2) GO TO 91
NN = IDINT(STKR(L))
TOP = TOP-1
L = LSTK(TOP)
N = NSTK(TOP)
91 IF (FIN.NE.7 .OR. N.LT.4) GO TO 93
DO 92 I = 1, 4
LS = L+I-1
ID(I) = IDINT(STKR(LS))
92 CONTINUE
IF (EQID(ID,UNIFOR).OR.EQID(ID,NORMAL)) GO TO 97
IF (EQID(ID,SEED)) GO TO 98
93 IF (N .GT. 1) GO TO 94
M = MAX0(IDINT(STKR(L)),0)
IF (RHS .EQ. 2) N = MAX0(NN,0)
IF (RHS .NE. 2) N = M
ERR = L+M*N - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
MSTK(TOP) = M
NSTK(TOP) = N
IF (M*N .EQ. 0) GO TO 99
94 DO 96 J = 1, N
DO 96 I = 1, M
LL = L+I-1+(J-1)*M
STKR(LL) = 0.0D0
STKI(LL) = 0.0D0
IF (I.EQ.J .OR. FIN.EQ.8) STKR(LL) = 1.0D0
IF (FIN.EQ.7 .AND. RAN(2).EQ.0) STKR(LL) = FLOP(URAND(RAN(1)))
IF (FIN.NE.7 .OR. RAN(2).EQ.0) GO TO 96
95 SR = 2.0D0*URAND(RAN(1))-1.0D0
SI = 2.0D0*URAND(RAN(1))-1.0D0
T = SR*SR + SI*SI
IF (T .GT. 1.0D0) GO TO 95
STKR(LL) = FLOP(SR*DSQRT(-2.0D0*DLOG(T)/T))
96 CONTINUE
GO TO 99
C
C SWITCH UNIFORM AND NORMAL
97 RAN(2) = ID(1) - UNIFOR(1)
MSTK(TOP) = 0
GO TO 99
C
C SEED
98 IF (RHS .EQ. 2) RAN(1) = NN
STKR(L) = RAN(1)
MSTK(TOP) = 1
IF (RHS .EQ. 2) MSTK(TOP) = 0
NSTK(TOP) = 1
GO TO 99
C
99 RETURN
END
SUBROUTINE MATLAB(INIT)
C INIT = 0 FOR ORDINARY FIRST ENTRY
C = POSITIVE FOR SUBSEQUENT ENTRIES
C = NEGATIVE FOR SILENT INITIALIZATION (SEE MATZ)
C
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER ALFA(52),ALFB(52),ALFL,CASE
INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /ALFS/ ALFA,ALFB,ALFL,CASE
COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
C
DOUBLE PRECISION S,T
INTEGER EPS(4),FLOPS(4),EYE(4),RAND(4)
C
C CHARACTER SET
C 0 10 20 30 40 50
C
C 0 0 A K U COLON : LESS <
C 1 1 B L V PLUS + GREAT >
C 2 2 C M W MINUS -
C 3 3 D N X STAR *
C 4 4 E O Y SLASH /
C 5 5 F P Z BSLASH \
C 6 6 G Q BLANK EQUAL =
C 7 7 H R LPAREN ( DOT .
C 8 8 I S RPAREN ) COMMA ,
C 9 9 J T SEMI ; QUOTE '
C
INTEGER ALPHA(52),ALPHB(52)
DATA ALPHA /1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,
$ 1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
$ 1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,
$ 1HU,1HV,1HW,1HX,1HY,1HZ,1H ,1H(,1H),1H;,
$ 1H:,1H+,1H-,1H*,1H/,1H\,1H=,1H.,1H,,1H',
$ 1H<,1H>/
C
C ALTERNATE CHARACTER SET
C
DATA ALPHB /1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,
$ 1Ha,1Hb,1Hc,1Hd,1He,1Hf,1Hg,1Hh,1Hi,1Hj,
$ 1Hk,1Hl,1Hm,1Hn,1Ho,1Hp,1Hq,1Hr,1Hs,1Ht,
$ 1Hu,1Hv,1Hw,1Hx,1Hy,1Hz,1H ,1H(,1H),1H;,
$ 1H|,1H+,1H-,1H*,1H/,1H$,1H=,1H.,1H,,1H",
$ 1H[,1H]/
C
DATA EPS/14,25,28,36/,FLOPS/15,21,24,25/
DATA EYE/14,34,14,36/,RAND/27,10,23,13/
C
IF (INIT .GT. 0) GO TO 90
C
C RTE = UNIT NUMBER FOR TERMINAL INPUT
RTE = 9
CALL FILES(RTE,BUF)
RIO = RTE
C
C WTE = UNIT NUMBER FOR TERMINAL OUTPUT
WTE = 9
CALL FILES(WTE,BUF)
WIO = 0
C
IF (INIT .GE. 0) WRITE(WTE,100)
100 FORMAT(//1X,' < M A T L A B >'
$ /1X,' Version of 05/25/82')
C
C HIO = UNIT NUMBER FOR HELP FILE
HIO = 11
CALL FILES(HIO,BUF)
C
C RANDOM NUMBER SEED
RAN(1) = 0
C
C INITIAL LINE LIMIT
LCT(2) = 25
C
ALFL = 52
CASE = 0
C CASE = 1 for file names in lower case
DO 20 I = 1, ALFL
ALFA(I) = ALPHA(I)
ALFB(I) = ALPHB(I)
20 CONTINUE
C
VSIZE = 5005
LSIZE = 48
PSIZE = 32
BOT = LSIZE-3
CALL WSET(5,0.0D0,0.0D0,STKR(VSIZE-4),STKI(VSIZE-4),1)
CALL PUTID(IDSTK(1,LSIZE-3),EPS)
LSTK(LSIZE-3) = VSIZE-4
MSTK(LSIZE-3) = 1
NSTK(LSIZE-3) = 1
S = 1.0D0
30 S = S/2.0D0
T = 1.0D0 + S
IF (T .GT. 1.0D0) GO TO 30
STKR(VSIZE-4) = 2.0D0*S
CALL PUTID(IDSTK(1,LSIZE-2),FLOPS)
LSTK(LSIZE-2) = VSIZE-3
MSTK(LSIZE-2) = 1
NSTK(LSIZE-2) = 2
CALL PUTID(IDSTK(1,LSIZE-1), EYE)
LSTK(LSIZE-1) = VSIZE-1
MSTK(LSIZE-1) = -1
NSTK(LSIZE-1) = -1
STKR(VSIZE-1) = 1.0D0
CALL PUTID(IDSTK(1,LSIZE), RAND)
LSTK(LSIZE) = VSIZE
MSTK(LSIZE) = 1
NSTK(LSIZE) = 1
FMT = 1
FLP(1) = 0
FLP(2) = 0
DDT = 0
RAN(2) = 0
PTZ = 0
PT = PTZ
ERR = 0
IF (INIT .LT. 0) RETURN
C
90 CALL PARSE
IF (FUN .EQ. 1) CALL MATFN1
IF (FUN .EQ. 2) CALL MATFN2
IF (FUN .EQ. 3) CALL MATFN3
IF (FUN .EQ. 4) CALL MATFN4
IF (FUN .EQ. 5) CALL MATFN5
IF (FUN .EQ. 6) CALL MATFN6
IF (FUN .EQ. 21) CALL MATFN1
IF (FUN .NE. 99) GO TO 90
RETURN
END
SUBROUTINE PARSE
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
LOGICAL EQID
INTEGER SEMI,EQUAL,EOL,ID(4),EXCNT,LPAREN,RPAREN,COLON,PTS,ALFL
INTEGER BLANK,COMMA,LESS,GREAT,NAME,ANS(4),ENND(4),ELSE(4),P,R
DATA BLANK/36/,SEMI/39/,EQUAL/46/,EOL/99/,COMMA/48/,COLON/40/
DATA LPAREN/37/,RPAREN/38/,LESS/50/,GREAT/51/,NAME/1/,ALFL/52/
DATA ANS/10,23,28,36/,ENND/14,23,13,36/,ELSE/14,21,28,14/
C
01 R = 0
IF (ERR .GT. 0) PTZ = 0
IF (ERR.LE.0 .AND. PT.GT.PTZ) R = RSTK(PT)
IF (DDT .EQ. 1) WRITE(WTE,100) PT,R,PTZ,ERR
100 FORMAT(1X,'PARSE ',4I4)
IF (R.EQ.15) GO TO 93
IF (R.EQ.16 .OR. R.EQ.17) GO TO 94
SYM = EOL
TOP = 0
IF (RIO .NE. RTE) CALL FILES(-1*RIO,BUF)
RIO = RTE
LCT(3) = 0
LCT(4) = 2
LPT(1) = 1
10 IF (SYM.EQ.EOL .AND. MOD(LCT(4)/2,2).EQ.1) CALL PROMPT(LCT(4)/4)
IF (SYM .EQ. EOL) CALL GETLIN
ERR = 0
PT = PTZ
15 EXCNT = 0
IF (DDT .EQ. 1) WRITE(WTE,115) PT,TOP
115 FORMAT(1X,'STATE ',2I4)
LHS = 1
CALL PUTID(ID,ANS)
CALL GETSYM
IF (SYM.EQ.COLON .AND. CHAR.EQ.EOL) DDT = 1-DDT
IF (SYM .EQ. COLON) CALL GETSYM
IF (SYM.EQ.SEMI .OR. SYM.EQ.COMMA .OR. SYM.EQ.EOL) GO TO 80
IF (SYM .EQ. NAME) GO TO 20
IF (SYM .EQ. LESS) GO TO 40
IF (SYM .EQ. GREAT) GO TO 45
GO TO 50
C
C LHS BEGINS WITH NAME
20 CALL COMAND(SYN)
IF (ERR .GT. 0) GO TO 01
IF (FUN .EQ. 99) GO TO 95
IF (FIN .EQ. -15) GO TO 80
IF (FIN .LT. 0) GO TO 91
IF (FIN .GT. 0) GO TO 70
C IF NAME IS A FUNCTION, MUST BE RHS
RHS = 0
CALL FUNS(SYN)
IF (FIN .NE. 0) GO TO 50
C PEEK ONE CHARACTER AHEAD
IF (CHAR.EQ.SEMI .OR. CHAR.EQ.COMMA .OR. CHAR.EQ.EOL)
$ CALL PUTID(ID,SYN)
IF (CHAR .EQ. EQUAL) GO TO 25
IF (CHAR .EQ. LPAREN) GO TO 30
GO TO 50
C
C LHS IS SIMPLE VARIABLE
25 CALL PUTID(ID,SYN)
CALL GETSYM
CALL GETSYM
GO TO 50
C
C LHS IS NAME(...)
30 LPT(5) = LPT(4)
CALL PUTID(ID,SYN)
CALL GETSYM
32 CALL GETSYM
EXCNT = EXCNT+1
PT = PT+1
CALL PUTID(IDS(1,PT), ID)
PSTK(PT) = EXCNT
RSTK(PT) = 1
C *CALL* EXPR
GO TO 92
35 CALL PUTID(ID,IDS(1,PT))
EXCNT = PSTK(PT)
PT = PT-1
IF (SYM .EQ. COMMA) GO TO 32
IF (SYM .NE. RPAREN) CALL ERROR(3)
IF (ERR .GT. 0) GO TO 01
IF (ERR .GT. 0) RETURN
IF (SYM .EQ. RPAREN) CALL GETSYM
IF (SYM .EQ. EQUAL) GO TO 50
C LHS IS REALLY RHS, FORGET SCAN JUST DONE
TOP = TOP - EXCNT
LPT(4) = LPT(5)
CHAR = LPAREN
SYM = NAME
CALL PUTID(SYN,ID)
CALL PUTID(ID,ANS)
EXCNT = 0
GO TO 50
C
C MULTIPLE LHS
40 LPT(5) = LPT(4)
PTS = PT
CALL GETSYM
41 IF (SYM .NE. NAME) GO TO 43
CALL PUTID(ID,SYN)
CALL GETSYM
IF (SYM .EQ. GREAT) GO TO 42
IF (SYM .EQ. COMMA) CALL GETSYM
PT = PT+1
LHS = LHS+1
PSTK(PT) = 0
CALL PUTID(IDS(1,PT),ID)
GO TO 41
42 CALL GETSYM
IF (SYM .EQ. EQUAL) GO TO 50
43 LPT(4) = LPT(5)
PT = PTS
LHS = 1
SYM = LESS
CHAR = LPT(4)-1
CHAR = LIN(CHAR)
CALL PUTID(ID,ANS)
GO TO 50
C
C MACRO STRING
45 CALL GETSYM
IF (DDT .EQ. 1) WRITE(WTE,145) PT,TOP
145 FORMAT(1X,'MACRO ',2I4)
IF (SYM.EQ.LESS .AND. CHAR.EQ.EOL) CALL ERROR(28)
IF (ERR .GT. 0) GO TO 01
PT = PT+1
RSTK(PT) = 20
C *CALL* EXPR
GO TO 92
46 PT = PT-1
IF (SYM.NE.LESS .AND. SYM.NE.EOL) CALL ERROR(37)
IF (ERR .GT. 0) GO TO 01
IF (SYM .EQ. LESS) CALL GETSYM
K = LPT(6)
LIN(K+1) = LPT(1)
LIN(K+2) = LPT(2)
LIN(K+3) = LPT(6)
LPT(1) = K + 4
C TRANSFER STACK TO INPUT LINE
K = LPT(1)
L = LSTK(TOP)
N = MSTK(TOP)*NSTK(TOP)
DO 48 J = 1, N
LS = L + J-1
LIN(K) = IDINT(STKR(LS))
IF (LIN(K).LT.0 .OR. LIN(K).GE.ALFL) CALL ERROR(37)
IF (ERR .GT. 0) RETURN
IF (K.LT.1024) K = K+1
IF (K.EQ.1024) WRITE(WTE,47) K
47 FORMAT(1X,'INPUT BUFFER LIMIT IS ',I4,' CHARACTERS.')
48 CONTINUE
TOP = TOP-1
LIN(K) = EOL
LPT(6) = K
LPT(4) = LPT(1)
LPT(3) = 0
LPT(2) = 0
LCT(1) = 0
CHAR = BLANK
PT = PT+1
PSTK(PT) = LPT(1)
RSTK(PT) = 21
C *CALL* PARSE
GO TO 15
49 PT = PT-1
IF (DDT .EQ. 1) WRITE(WTE,149) PT,TOP
149 FORMAT(1X,'MACEND',2I4)
K = LPT(1) - 4
LPT(1) = LIN(K+1)
LPT(4) = LIN(K+2)
LPT(6) = LIN(K+3)
CHAR = BLANK
CALL GETSYM
GO TO 80
C
C LHS FINISHED, START RHS
50 IF (SYM .EQ. EQUAL) CALL GETSYM
PT = PT+1
CALL PUTID(IDS(1,PT),ID)
PSTK(PT) = EXCNT
RSTK(PT) = 2
C *CALL* EXPR
GO TO 92
55 IF (SYM.EQ.SEMI .OR. SYM.EQ.COMMA .OR. SYM.EQ.EOL) GO TO 60
IF (SYM.EQ.NAME .AND. EQID(SYN,ELSE)) GO TO 60
IF (SYM.EQ.NAME .AND. EQID(SYN,ENND)) GO TO 60
CALL ERROR(40)
IF (ERR .GT. 0) GO TO 01
C
C STORE RESULTS
60 RHS = PSTK(PT)
CALL STACKP(IDS(1,PT))
IF (ERR .GT. 0) GO TO 01
PT = PT-1
LHS = LHS-1
IF (LHS .GT. 0) GO TO 60
GO TO 70
C
C UPDATE AND POSSIBLY PRINT OPERATION COUNTS
70 K = FLP(1)
IF (K .NE. 0) STKR(VSIZE-3) = DFLOAT(K)
STKR(VSIZE-2) = STKR(VSIZE-2) + DFLOAT(K)
FLP(1) = 0
IF (.NOT.(CHAR.EQ.COMMA .OR. (SYM.EQ.COMMA .AND. CHAR.EQ.EOL)))
$ GO TO 80
CALL GETSYM
I5 = 10**5
LUNIT = WTE
71 IF (K .EQ. 0) WRITE(LUNIT,171)
171 FORMAT(/1X,' no flops')
IF (K .EQ. 1) WRITE(LUNIT,172)
172 FORMAT(/1X,' 1 flop')
IF (1.LT.K .AND. K.LT.100000) WRITE(LUNIT,173) K
173 FORMAT(/1X,I5,' flops')
IF (100000 .LE. K) WRITE(LUNIT,174) K
174 FORMAT(/1X,I9,' flops')
IF (LUNIT.EQ.WIO .OR. WIO.EQ.0) GO TO 80
LUNIT = WIO
GO TO 71
C
C FINISH STATEMENT
80 FIN = 0
P = 0
R = 0
IF (PT .GT. 0) P = PSTK(PT)
IF (PT .GT. 0) R = RSTK(PT)
IF (DDT .EQ. 1) WRITE(WTE,180) PT,PTZ,P,R,LPT(1)
180 FORMAT(1X,'FINISH',5I4)
IF (SYM.EQ.COMMA .OR. SYM.EQ.SEMI) GO TO 15
IF (R.EQ.21 .AND. P.EQ.LPT(1)) GO TO 49
IF (PT .GT. PTZ) GO TO 91
GO TO 10
C
C SIMULATE RECURSION
91 CALL CLAUSE
IF (ERR .GT. 0) GO TO 01
IF (PT .LE. PTZ) GO TO 15
R = RSTK(PT)
IF (R .EQ. 21) GO TO 49
GO TO (99,99,92,92,92,99,99,99,99,99,99,99,15,15,99,99,99,99,99),R
C
92 CALL EXPR
IF (ERR .GT. 0) GO TO 01
R = RSTK(PT)
GO TO (35,55,91,91,91,93,93,99,99,94,94,99,99,99,99,99,99,94,94,
$ 46),R
C
93 CALL TERM
IF (ERR .GT. 0) GO TO 01
R = RSTK(PT)
GO TO (99,99,99,99,99,92,92,94,94,99,99,99,99,99,95,99,99,99,99),R
C
94 CALL FACTOR
IF (ERR .GT. 0) GO TO 01
R = RSTK(PT)
GO TO (99,99,99,99,99,99,99,93,93,92,92,94,99,99,99,95,95,92,92),R
C
C CALL MATFNS BY RETURNING TO MATLAB
95 IF (FIN.GT.0 .AND. MSTK(TOP).LT.0) CALL ERROR(14)
IF (ERR .GT. 0) GO TO 01
RETURN
C
99 CALL ERROR(22)
GO TO 01
END
SUBROUTINE PLOT(LUNIT,X,Y,N,P,K,BUF)
DOUBLE PRECISION X(N),Y(N),P(1)
INTEGER BUF(79)
C
C PLOT X VS. Y ON LUNIT
C IF K IS NONZERO, THEN P(1),...,P(K) ARE EXTRA PARAMETERS
C BUF IS WORK SPACE
C
DOUBLE PRECISION XMIN,YMIN,XMAX,YMAX,DY,DX,Y1,Y0
INTEGER AST,BLANK,H,W
DATA AST/1H*/,BLANK/1H /,H/20/,W/79/
C
C H = HEIGHT, W = WIDTH
C
IF (K .GT. 0) WRITE(LUNIT,01) (P(I), I=1,K)
01 FORMAT('Extra parameters',10f5.1)
XMIN = X(1)
XMAX = X(1)
YMIN = Y(1)
YMAX = Y(1)
DO 10 I = 1, N
XMIN = DMIN1(XMIN,X(I))
XMAX = DMAX1(XMAX,X(I))
YMIN = DMIN1(YMIN,Y(I))
YMAX = DMAX1(YMAX,Y(I))
10 CONTINUE
DX = XMAX - XMIN
IF (DX .EQ. 0.0D0) DX = 1.0D0
DY = YMAX - YMIN
WRITE(LUNIT,35)
DO 40 L = 1, H
DO 20 J = 1, W
BUF(J) = BLANK
20 CONTINUE
Y1 = YMIN + (H-L+1)*DY/H
Y0 = YMIN + (H-L)*DY/H
JMAX = 1
DO 30 I = 1, N
IF (Y(I) .GT. Y1) GO TO 30
IF (L.NE.H .AND. Y(I).LE.Y0) GO TO 30
J = 1 + (W-1)*(X(I) - XMIN)/DX
BUF(J) = AST
JMAX = MAX0(JMAX,J)
30 CONTINUE
WRITE(LUNIT,35) (BUF(J),J=1,JMAX)
35 FORMAT(79A1)
40 CONTINUE
RETURN
END
SUBROUTINE PRINT(ID,K)
C PRIMARY OUTPUT ROUTINE
INTEGER ID(4),K
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER ALFA(52),ALFB(52),ALFL,CASE
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /ALFS/ ALFA,ALFB,ALFL,CASE
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
DOUBLE PRECISION S,TR,TI,PR(12),PI(12),ROUND
INTEGER FNO(11),FNL(11),SIG(12),PLUS,MINUS,BLANK,TYP,F
DATA PLUS/41/,MINUS/42/,BLANK/36/
C FORMAT NUMBERS AND LENGTHS
DATA FNO /11,12,21,22,23,24,31,32,33,34,-1/
DATA FNL /12, 6, 8, 4, 6, 3, 4, 2, 3, 1, 1/
C FMT 1 2 3 4 5
C SHORT LONG SHORT E LONG E Z
C TYP 1 2 3
C INTEGER REAL COMPLEX
IF (LCT(1) .LT. 0) GO TO 99
L = LSTK(K)
M = MSTK(K)
N = NSTK(K)
MN = M*N
TYP = 1
S = 0.0D0
DO 10 I = 1, MN
LS = L+I-1
TR = STKR(LS)
TI = STKI(LS)
S = DMAX1(S,DABS(TR),DABS(TI))
IF (ROUND(TR) .NE. TR) TYP = MAX0(2,TYP)
IF (TI .NE. 0.0D0) TYP = 3
10 CONTINUE
IF (S .NE. 0.0D0) S = DLOG10(S)
KS = IDINT(S)
IF (-2 .LE. KS .AND. KS .LE. 1) KS = 0
IF (KS .EQ. 2 .AND. FMT .EQ. 1 .AND. TYP .EQ. 2) KS = 0
IF (TYP .EQ. 1 .AND. KS .LE. 2) F = 1
IF (TYP .EQ. 1 .AND. KS .GT. 2) F = 2
IF (TYP .EQ. 1 .AND. KS .GT. 9) TYP = 2
IF (TYP .EQ. 2) F = FMT + 2
IF (TYP .EQ. 3) F = FMT + 6
IF (MN.EQ.1 .AND. KS.NE.0 .AND. FMT.LT.3 .AND. TYP.NE.1) F = F+2
IF (FMT .EQ. 5) F = 11
JINC = FNL(F)
F = FNO(F)
S = 1.0D0
IF (F.EQ.21 .OR. F.EQ.22 .OR. F.EQ.31 .OR. F.EQ.32) S = 10.0D0**KS
LS = ((N-1)/JINC+1)*M + 2
IF (LCT(1) + LS .LE. LCT(2)) GO TO 20
LCT(1) = 0
WRITE(WTE,43) LS
READ(RTE,44,END=19) LS
CDC.. IF (EOF(RTE).NE.0) GO TO 19
IF (LS .EQ. ALFA(BLANK+1)) GO TO 20
LCT(1) = -1
GO TO 99
19 CALL FILES(-1*RTE,BUF)
20 CONTINUE
WRITE(WTE,44)
IF (WIO .NE. 0) WRITE(WIO,44)
CALL PRNTID(ID,-1)
LCT(1) = LCT(1)+2
LUNIT = WTE
50 IF (S .NE. 1.0D0) WRITE(LUNIT,41) S
DO 80 J1 = 1, N, JINC
J2 = MIN0(N, J1+JINC-1)
WRITE(LUNIT,44)
IF (N .GT. JINC) WRITE(LUNIT,42) J1,J2
DO 70 I = 1, M
JM = J2-J1+1
DO 60 J = 1, JM
LS = L+I-1+(J+J1-2)*M
PR(J) = STKR(LS)/S
PI(J) = DABS(STKI(LS)/S)
SIG(J) = ALFA(PLUS+1)
IF (STKI(LS) .LT. 0.0D0) SIG(J) = ALFA(MINUS+1)
60 CONTINUE
IF (F .EQ. 11) WRITE(LUNIT,11)(PR(J),J=1,JM)
IF (F .EQ. 12) WRITE(LUNIT,12)(PR(J),J=1,JM)
IF (F .EQ. 21) WRITE(LUNIT,21)(PR(J),J=1,JM)
IF (F .EQ. 22) WRITE(LUNIT,22)(PR(J),J=1,JM)
IF (F .EQ. 23) WRITE(LUNIT,23)(PR(J),J=1,JM)
IF (F .EQ. 24) WRITE(LUNIT,24)(PR(J),J=1,JM)
IF (F .EQ. 31) WRITE(LUNIT,31)(PR(J),SIG(J),PI(J),J=1,JM)
IF (F .EQ. 32) WRITE(LUNIT,32)(PR(J),SIG(J),PI(J),J=1,JM)
IF (F .EQ. 33) WRITE(LUNIT,33)(PR(J),SIG(J),PI(J),J=1,JM)
IF (F .EQ. 34) WRITE(LUNIT,34)(PR(J),SIG(J),PI(J),J=1,JM)
IF (F .EQ. -1) CALL FORMZ(LUNIT,STKR(LS),STKI(LS))
LCT(1) = LCT(1)+1
70 CONTINUE
80 CONTINUE
IF (LUNIT.EQ.WIO .OR. WIO.EQ.0) GO TO 99
LUNIT = WIO
GO TO 50
99 RETURN
C
11 FORMAT(1X,12F6.0)
12 FORMAT(1X,6F12.0)
21 FORMAT(1X,F9.4,7F10.4)
22 FORMAT(1X,F19.15,3F20.15)
23 FORMAT(1X,1P6D13.4)
24 FORMAT(1X,1P3D24.15)
31 FORMAT(1X,4(F9.4,' ',A1,F7.4,'i'))
32 FORMAT(1X,F19.15,A1,F18.15,'i',F20.15,A1,F18.15,'i')
33 FORMAT(1X,3(1PD13.4,' ',A1,1PD10.4,'i'))
34 FORMAT(1X,1PD24.15,' ',A1,1PD21.15,'i')
41 FORMAT(/1X,' ',1PD9.1,2H *)
42 FORMAT(1X,' COLUMNS',I3,' THRU',I3)
43 FORMAT(/1X,'AT LEAST ',I5,' MORE LINES.',
$ ' ENTER BLANK LINE TO CONTINUE OUTPUT.')
44 FORMAT(A1)
C
END
SUBROUTINE PRNTID(ID,ARGCNT)
C PRINT VARIABLE NAMES
INTEGER ID(4,1),ARGCNT
INTEGER ALFA(52),ALFB(52),ALFL,CASE
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /ALFS/ ALFA,ALFB,ALFL,CASE
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER EQUAL
DATA EQUAL/46/
J1 = 1
10 J2 = MIN0(J1+7,IABS(ARGCNT))
L = 0
DO 15 J = J1,J2
DO 15 I = 1, 4
K = ID(I,J)+1
L = L+1
BUF(L) = ALFA(K)
15 CONTINUE
IF (ARGCNT .EQ. -1) L=L+1
IF (ARGCNT .EQ. -1) BUF(L) = ALFA(EQUAL+1)
WRITE(WTE,20) (BUF(I),I=1,L)
IF (WIO .NE. 0) WRITE(WIO,20) (BUF(I),I=1,L)
20 FORMAT(1X,8(4A1,2H ))
J1 = J1+8
IF (J1 .LE. IABS(ARGCNT)) GO TO 10
RETURN
END
SUBROUTINE PROMPT(PAUSE)
INTEGER PAUSE
C
C ISSUE MATLAB PROMPT WITH OPTIONAL PAUSE
C
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
WRITE(WTE,10)
IF (WIO .NE. 0) WRITE(WIO,10)
10 FORMAT(/1X,'<>',$)
IF (PAUSE .EQ. 1) READ(RTE,20) DUMMY
20 FORMAT(A1)
RETURN
END
DOUBLE PRECISION FUNCTION PYTHAG(A,B)
DOUBLE PRECISION A,B
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
DOUBLE PRECISION P,Q,R,S,T
P = DMAX1(DABS(A),DABS(B))
Q = DMIN1(DABS(A),DABS(B))
IF (Q .EQ. 0.0D0) GO TO 20
IF (DDT .EQ. 25) WRITE(WTE,1)
IF (DDT .EQ. 25) WRITE(WTE,2) P,Q
1 FORMAT(1X,'PYTHAG',1P2D23.15)
2 FORMAT(1X,1P2D23.15)
10 R = (Q/P)**2
T = 4.0D0 + R
IF (T .EQ. 4.0D0) GO TO 20
S = R/T
P = P + 2.0D0*P*S
Q = Q*S
IF (DDT .EQ. 25) WRITE(WTE,2) P,Q
GO TO 10
20 PYTHAG = P
RETURN
END
SUBROUTINE RAT(X,LEN,MAXD,A,B,D)
INTEGER LEN,MAXD
DOUBLE PRECISION X,A,B,D(LEN)
C
C A/B = CONTINUED FRACTION APPROXIMATION TO X
C USING LEN TERMS EACH LESS THAN MAXD
C
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
DOUBLE PRECISION S,T,Z,ROUND
Z = X
DO 10 I = 1, LEN
K = I
D(K) = ROUND(Z)
Z = Z - D(K)
IF (DABS(Z)*DFLOAT(MAXD) .LE. 1.0D0) GO TO 20
Z = 1.0D0/Z
10 CONTINUE
20 T = D(K)
S = 1.0D0
IF (K .LT. 2) GO TO 40
DO 30 IB = 2, K
I = K+1-IB
Z = T
T = D(I)*T + S
S = Z
30 CONTINUE
40 IF (S .LT. 0.0D0) T = -T
IF (S .LT. 0.0D0) S = -S
IF (DDT .EQ. 27) WRITE(WTE,50) X,T,S,(D(I),I=1,K)
50 FORMAT(/1X,1PD23.15,0PF8.0,' /',F8.0,4X,6F5.0/(1X,45X,6F5.0))
A = T
B = S
RETURN
END
SUBROUTINE SAVLOD(LUNIT,ID,M,N,IMG,JOB,XREAL,XIMAG)
INTEGER LUNIT,ID(4),M,N,IMG,JOB
DOUBLE PRECISION XREAL(1),XIMAG(1)
C
C IMPLEMENT SAVE AND LOAD
C LUNIT = LOGICAL UNIT NUMBER
C ID = NAME, FORMAT 4A1
C M, N = DIMENSIONS
C IMG = NONZERO IF XIMAG IS NONZERO
C JOB = 0 FOR SAVE
C = SPACE AVAILABLE FOR LOAD
C XREAL, XIMAG = REAL AND OPTIONAL IMAGINARY PARTS
C
C SYSTEM DEPENDENT FORMATS
101 FORMAT(4A1,3I4)
102 FORMAT(4Z18)
C
IF (JOB .GT. 0) GO TO 20
C
C SAVE
10 WRITE(LUNIT,101) ID,M,N,IMG
DO 15 J = 1, N
K = (J-1)*M+1
L = J*M
WRITE(LUNIT,102) (XREAL(I),I=K,L)
IF (IMG .NE. 0) WRITE(LUNIT,102) (XIMAG(I),I=K,L)
15 CONTINUE
RETURN
C
C LOAD
20 READ(LUNIT,101,END=30) ID,M,N,IMG
IF (M*N .GT. JOB) GO TO 30
DO 25 J = 1, N
K = (J-1)*M+1
L = J*M
READ(LUNIT,102,END=30) (XREAL(I),I=K,L)
IF (IMG .NE. 0) READ(LUNIT,102,END=30) (XIMAG(I),I=K,L)
25 CONTINUE
RETURN
C
C END OF FILE
30 M = 0
N = 0
RETURN
END
SUBROUTINE STACK1(OP)
INTEGER OP
C
C UNARY OPERATIONS
C
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER QUOTE
DATA QUOTE/49/
IF (DDT .EQ. 1) WRITE(WTE,100) OP
100 FORMAT(1X,'STACK1',I4)
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
MN = M*N
IF (MN .EQ. 0) GO TO 99
IF (OP .EQ. QUOTE) GO TO 30
C
C UNARY MINUS
CALL WRSCAL(MN,-1.0D0,STKR(L),STKI(L),1)
GO TO 99
C
C TRANSPOSE
30 LL = L + MN
ERR = LL+MN - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
CALL WCOPY(MN,STKR(L),STKI(L),1,STKR(LL),STKI(LL),1)
M = NSTK(TOP)
N = MSTK(TOP)
MSTK(TOP) = M
NSTK(TOP) = N
DO 50 I = 1, M
DO 50 J = 1, N
LS = L+MN+(J-1)+(I-1)*N
LL = L+(I-1)+(J-1)*M
STKR(LL) = STKR(LS)
STKI(LL) = -STKI(LS)
50 CONTINUE
GO TO 99
99 RETURN
END
SUBROUTINE STACK2(OP)
INTEGER OP
C
C BINARY AND TERNARY OPERATIONS
C
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
DOUBLE PRECISION WDOTUR,WDOTUI
DOUBLE PRECISION SR,SI,E1,ST,E2,FLOP
INTEGER PLUS,MINUS,STAR,DSTAR,SLASH,BSLASH,DOT,COLON
DATA PLUS/41/,MINUS/42/,STAR/43/,DSTAR/54/,SLASH/44/
DATA BSLASH/45/,DOT/47/,COLON/40/
C
IF (DDT .EQ. 1) WRITE(WTE,100) OP
100 FORMAT(1X,'STACK2',I4)
L2 = LSTK(TOP)
M2 = MSTK(TOP)
N2 = NSTK(TOP)
TOP = TOP-1
L = LSTK(TOP)
M = MSTK(TOP)
N = NSTK(TOP)
FUN = 0
IF (OP .EQ. PLUS) GO TO 01
IF (OP .EQ. MINUS) GO TO 03
IF (OP .EQ. STAR) GO TO 05
IF (OP .EQ. DSTAR) GO TO 30
IF (OP .EQ. SLASH) GO TO 20
IF (OP .EQ. BSLASH) GO TO 25
IF (OP .EQ. COLON) GO TO 60
IF (OP .GT. 2*DOT) GO TO 80
IF (OP .GT. DOT) GO TO 70
C
C ADDITION
01 IF (M .LT. 0) GO TO 50
IF (M2 .LT. 0) GO TO 52
IF (M .NE. M2) CALL ERROR(8)
IF (ERR .GT. 0) RETURN
IF (N .NE. N2) CALL ERROR(8)
IF (ERR .GT. 0) RETURN
CALL WAXPY(M*N,1.0D0,0.0D0,STKR(L2),STKI(L2),1,
$ STKR(L),STKI(L),1)
GO TO 99
C
C SUBTRACTION
03 IF (M .LT. 0) GO TO 54
IF (M2 .LT. 0) GO TO 56
IF (M .NE. M2) CALL ERROR(9)
IF (ERR .GT. 0) RETURN
IF (N .NE. N2) CALL ERROR(9)
IF (ERR .GT. 0) RETURN
CALL WAXPY(M*N,-1.0D0,0.0D0,STKR(L2),STKI(L2),1,
$ STKR(L),STKI(L),1)
GO TO 99
C
C MULTIPLICATION
05 IF (M2*M2*N2 .EQ. 1) GO TO 10
IF (M*N .EQ. 1) GO TO 11
IF (M2*N2 .EQ. 1) GO TO 10
IF (N .NE. M2) CALL ERROR(10)
IF (ERR .GT. 0) RETURN
MN = M*N2
LL = L + MN
ERR = LL+M*N+M2*N2 - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
CALL WCOPY(M*N+M2*N2,STKR(L),STKI(L),-1,STKR(LL),STKI(LL),-1)
DO 08 J = 1, N2
DO 08 I = 1, M
K1 = L + MN + (I-1)
K2 = L2 + MN + (J-1)*M2
K = L + (I-1) + (J-1)*M
STKR(K) = WDOTUR(N,STKR(K1),STKI(K1),M,STKR(K2),STKI(K2),1)
STKI(K) = WDOTUI(N,STKR(K1),STKI(K1),M,STKR(K2),STKI(K2),1)
08 CONTINUE
NSTK(TOP) = N2
GO TO 99
C
C MULTIPLICATION BY SCALAR
10 SR = STKR(L2)
SI = STKI(L2)
L1 = L
GO TO 13
11 SR = STKR(L)
SI = STKI(L)
L1 = L+1
MSTK(TOP) = M2
NSTK(TOP) = N2
13 MN = MSTK(TOP)*NSTK(TOP)
CALL WSCAL(MN,SR,SI,STKR(L1),STKI(L1),1)
IF (L1.NE.L)
$ CALL WCOPY(MN,STKR(L1),STKI(L1),1,STKR(L),STKI(L),1)
GO TO 99
C
C RIGHT DIVISION
20 IF (M2*N2 .EQ. 1) GO TO 21
IF (M2 .EQ. N2) FUN = 1
IF (M2 .NE. N2) FUN = 4
FIN = -1
RHS = 2
GO TO 99
21 SR = STKR(L2)
SI = STKI(L2)
MN = M*N
DO 22 I = 1, MN
LL = L+I-1
CALL WDIV(STKR(LL),STKI(LL),SR,SI,STKR(LL),STKI(LL))
IF (ERR .GT. 0) RETURN
22 CONTINUE
GO TO 99
C
C LEFT DIVISION
25 IF (M*N .EQ. 1) GO TO 26
IF (M .EQ. N) FUN = 1
IF (M .NE. N) FUN = 4
FIN = -2
RHS = 2
GO TO 99
26 SR = STKR(L)
SI = STKI(L)
MSTK(TOP) = M2
NSTK(TOP) = N2
MN = M2*N2
DO 27 I = 1, MN
LL = L+I-1
CALL WDIV(STKR(LL+1),STKI(LL+1),SR,SI,STKR(LL),STKI(LL))
IF (ERR .GT. 0) RETURN
27 CONTINUE
GO TO 99
C
C POWER
30 IF (M2*N2 .NE. 1) CALL ERROR(30)
IF (ERR .GT. 0) RETURN
IF (M .NE. N) CALL ERROR(20)
IF (ERR .GT. 0) RETURN
NEXP = IDINT(STKR(L2))
IF (STKR(L2) .NE. DFLOAT(NEXP)) GO TO 39
IF (STKI(L2) .NE. 0.0D0) GO TO 39
IF (NEXP .LT. 2) GO TO 39
MN = M*N
ERR = L2+MN+N - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
CALL WCOPY(MN,STKR(L),STKI(L),1,STKR(L2),STKI(L2),1)
L3 = L2+MN
DO 36 KEXP = 2, NEXP
DO 35 J = 1, N
LS = L+(J-1)*N
CALL WCOPY(N,STKR(LS),STKI(LS),1,STKR(L3),STKI(L3),1)
DO 34 I = 1, N
LS = L2+I-1
LL = L+I-1+(J-1)*N
STKR(LL) = WDOTUR(N,STKR(LS),STKI(LS),N,STKR(L3),STKI(L3),1)
STKI(LL) = WDOTUI(N,STKR(LS),STKI(LS),N,STKR(L3),STKI(L3),1)
34 CONTINUE
35 CONTINUE
36 CONTINUE
GO TO 99
C
C NONINTEGER OR NONPOSITIVE POWER, USE EIGENVECTORS
39 FUN = 2
FIN = 0
GO TO 99
C
C ADD OR SUBTRACT SCALAR
50 IF (M2 .NE. N2) CALL ERROR(8)
IF (ERR .GT. 0) RETURN
M = M2
N = N2
MSTK(TOP) = M
NSTK(TOP) = N
SR = STKR(L)
SI = STKI(L)
CALL WCOPY(M*N,STKR(L+1),STKI(L+1),1,STKR(L),STKI(L),1)
GO TO 58
52 IF (M .NE. N) CALL ERROR(8)
IF (ERR .GT. 0) RETURN
SR = STKR(L2)
SI = STKI(L2)
GO TO 58
54 IF (M2 .NE. N2) CALL ERROR(9)
IF (ERR .GT. 0) RETURN
M = M2
N = N2
MSTK(TOP) = M
NSTK(TOP) = N
SR = STKR(L)
SI = STKI(L)
CALL WCOPY(M*N,STKR(L+1),STKI(L+1),1,STKR(L),STKI(L),1)
CALL WRSCAL(M*N,-1.0D0,STKR(L),STKI(L),1)
GO TO 58
56 IF (M .NE. N) CALL ERROR(9)
IF (ERR .GT. 0) RETURN
SR = -STKR(L2)
SI = -STKI(L2)
GO TO 58
58 DO 59 I = 1, N
LL = L + (I-1)*(N+1)
STKR(LL) = FLOP(STKR(LL)+SR)
STKI(LL) = FLOP(STKI(LL)+SI)
59 CONTINUE
GO TO 99
C
C COLON
60 E2 = STKR(L2)
ST = 1.0D0
N = 0
IF (RHS .LT. 3) GO TO 61
ST = STKR(L)
TOP = TOP-1
L = LSTK(TOP)
IF (ST .EQ. 0.0D0) GO TO 63
61 E1 = STKR(L)
C CHECK FOR CLAUSE
IF (RSTK(PT) .EQ. 3) GO TO 64
ERR = L + MAX0(3,IDINT((E2-E1)/ST)) - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
62 IF (ST .GT. 0.0D0 .AND. STKR(L) .GT. E2) GO TO 63
IF (ST .LT. 0.0D0 .AND. STKR(L) .LT. E2) GO TO 63
N = N+1
L = L+1
STKR(L) = E1 + DFLOAT(N)*ST
STKI(L) = 0.0D0
GO TO 62
63 NSTK(TOP) = N
MSTK(TOP) = 1
IF (N .EQ. 0) MSTK(TOP) = 0
GO TO 99
C
C FOR CLAUSE
64 STKR(L) = E1
STKR(L+1) = ST
STKR(L+2) = E2
MSTK(TOP) = -3
NSTK(TOP) = -1
GO TO 99
C
C ELEMENTWISE OPERATIONS
70 OP = OP - DOT
IF (M.NE.M2 .OR. N.NE.N2) CALL ERROR(10)
IF (ERR .GT. 0) RETURN
MN = M*N
DO 72 I = 1, MN
J = L+I-1
K = L2+I-1
IF (OP .EQ. STAR)
$ CALL WMUL(STKR(J),STKI(J),STKR(K),STKI(K),STKR(J),STKI(J))
IF (OP .EQ. SLASH)
$ CALL WDIV(STKR(J),STKI(J),STKR(K),STKI(K),STKR(J),STKI(J))
IF (OP .EQ. BSLASH)
$ CALL WDIV(STKR(K),STKI(K),STKR(J),STKI(J),STKR(J),STKI(J))
IF (ERR .GT. 0) RETURN
72 CONTINUE
GO TO 99
C
C KRONECKER
80 FIN = OP - 2*DOT - STAR + 11
FUN = 6
TOP = TOP + 1
RHS = 2
GO TO 99
C
99 RETURN
END
SUBROUTINE STACKG(ID)
INTEGER ID(4)
C
C GET VARIABLES FROM STORAGE
C
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
LOGICAL EQID
IF (DDT .EQ. 1) WRITE(WTE,100) ID
100 FORMAT(1X,'STACKG',4I4)
CALL PUTID(IDSTK(1,BOT-1), ID)
K = LSIZE+1
10 K = K-1
IF (.NOT.EQID(IDSTK(1,K), ID)) GO TO 10
IF (K .GE. LSIZE-1 .AND. RHS .GT. 0) GO TO 98
IF (K .EQ. BOT-1) GO TO 98
LK = LSTK(K)
IF (RHS .EQ. 1) GO TO 40
IF (RHS .EQ. 2) GO TO 60
IF (RHS .GT. 2) CALL ERROR(21)
IF (ERR .GT. 0) RETURN
L = 1
IF (TOP .GT. 0) L = LSTK(TOP) + MSTK(TOP)*NSTK(TOP)
IF (TOP+1 .GE. BOT) CALL ERROR(18)
IF (ERR .GT. 0) RETURN
TOP = TOP+1
C
C LOAD VARIABLE TO TOP OF STACK
LSTK(TOP) = L
MSTK(TOP) = MSTK(K)
NSTK(TOP) = NSTK(K)
MN = MSTK(K)*NSTK(K)
ERR = L+MN - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
C IF RAND, MATFN6 GENERATES RANDOM NUMBER
IF (K .EQ. LSIZE) GO TO 97
CALL WCOPY(MN,STKR(LK),STKI(LK),1,STKR(L),STKI(L),1)
GO TO 99
C
C VECT(ARG)
40 IF (MSTK(TOP) .EQ. 0) GO TO 99
L = LSTK(TOP)
MN = MSTK(TOP)*NSTK(TOP)
MNK = MSTK(K)*NSTK(K)
IF (MSTK(TOP) .LT. 0) MN = MNK
DO 50 I = 1, MN
LL = L+I-1
LS = LK+I-1
IF (MSTK(TOP) .GT. 0) LS = LK + IDINT(STKR(LL)) - 1
IF (LS .LT. LK .OR. LS .GE. LK+MNK) CALL ERROR(21)
IF (ERR .GT. 0) RETURN
STKR(LL) = STKR(LS)
STKI(LL) = STKI(LS)
50 CONTINUE
MSTK(TOP) = 1
NSTK(TOP) = 1
IF (MSTK(K) .GT. 1) MSTK(TOP) = MN
IF (MSTK(K) .EQ. 1) NSTK(TOP) = MN
GO TO 99
C
C MATRIX(ARG,ARG)
60 TOP = TOP-1
L = LSTK(TOP)
IF (MSTK(TOP+1) .EQ. 0) MSTK(TOP) = 0
IF (MSTK(TOP) .EQ. 0) GO TO 99
L2 = LSTK(TOP+1)
M = MSTK(TOP)*NSTK(TOP)
IF (MSTK(TOP) .LT. 0) M = MSTK(K)
N = MSTK(TOP+1)*NSTK(TOP+1)
IF (MSTK(TOP+1) .LT. 0) N = NSTK(K)
L3 = L2 + N
MK = MSTK(K)
MNK = MSTK(K)*NSTK(K)
DO 70 J = 1, N
DO 70 I = 1, M
LI = L+I-1
IF (MSTK(TOP) .GT. 0) LI = L + IDINT(STKR(LI)) - 1
LJ = L2+J-1
IF (MSTK(TOP+1) .GT. 0) LJ = L2 + IDINT(STKR(LJ)) - 1
LS = LK + LI-L + (LJ-L2)*MK
IF (LS.LT.LK .OR. LS.GE.LK+MNK) CALL ERROR(21)
IF (ERR .GT. 0) RETURN
LL = L3 + I-1 + (J-1)*M
STKR(LL) = STKR(LS)
STKI(LL) = STKI(LS)
70 CONTINUE
MN = M*N
CALL WCOPY(MN,STKR(L3),STKI(L3),1,STKR(L),STKI(L),1)
MSTK(TOP) = M
NSTK(TOP) = N
GO TO 99
97 FIN = 7
FUN = 6
RETURN
98 FIN = 0
RETURN
99 FIN = -1
FUN = 0
RETURN
END
SUBROUTINE STACKP(ID)
INTEGER ID(4)
C
C PUT VARIABLES INTO STORAGE
C
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
LOGICAL EQID
INTEGER SEMI
DATA SEMI/39/
IF (DDT .EQ. 1) WRITE(WTE,100) ID
100 FORMAT(1X,'STACKP',4I4)
IF (TOP .LE. 0) CALL ERROR(1)
IF (ERR .GT. 0) RETURN
CALL FUNS(ID)
IF (FIN .NE. 0) CALL ERROR(25)
IF (ERR .GT. 0) RETURN
M = MSTK(TOP)
N = NSTK(TOP)
IF (M .GT. 0) L = LSTK(TOP)
IF (M .LT. 0) CALL ERROR(14)
IF (ERR .GT. 0) RETURN
IF (M .EQ. 0 .AND. N .NE. 0) GO TO 99
MN = M*N
LK = 0
MK = 1
NK = 0
LT = 0
MT = 0
NT = 0
C
C DOES VARIABLE ALREADY EXIST
CALL PUTID(IDSTK(1,BOT-1),ID)
K = LSIZE+1
05 K = K-1
IF (.NOT.EQID(IDSTK(1,K),ID)) GO TO 05
IF (K .EQ. BOT-1) GO TO 30
LK = LSTK(K)
MK = MSTK(K)
NK = NSTK(K)
MNK = MK*NK
IF (RHS .EQ. 0) GO TO 20
IF (RHS .GT. 2) CALL ERROR(15)
IF (ERR .GT. 0) RETURN
MT = MK
NT = NK
LT = L + MN
ERR = LT + MNK - LSTK(BOT)
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
CALL WCOPY(MNK,STKR(LK),STKI(LK),1,STKR(LT),STKI(LT),1)
C
C DOES IT FIT
20 IF (RHS.EQ.0 .AND. MN.EQ.MNK) GO TO 40
IF (K .GE. LSIZE-3) CALL ERROR(13)
IF (ERR .GT. 0) RETURN
C
C SHIFT STORAGE
IF (K .EQ. BOT) GO TO 25
LS = LSTK(BOT)
LL = LS + MNK
CALL WCOPY(LK-LS,STKR(LS),STKI(LS),-1,STKR(LL),STKI(LL),-1)
KM1 = K-1
DO 24 IB = BOT, KM1
I = BOT+KM1-IB
CALL PUTID(IDSTK(1,I+1),IDSTK(1,I))
MSTK(I+1) = MSTK(I)
NSTK(I+1) = NSTK(I)
LSTK(I+1) = LSTK(I)+MNK
24 CONTINUE
C
C DESTROY OLD VARIABLE
25 BOT = BOT+1
C
C CREATE NEW VARIABLE
30 IF (MN .EQ. 0) GO TO 99
IF (BOT-2 .LE. TOP) CALL ERROR(18)
IF (ERR .GT. 0) RETURN
K = BOT-1
CALL PUTID(IDSTK(1,K), ID)
IF (RHS .EQ. 1) GO TO 50
IF (RHS .EQ. 2) GO TO 55
C
C STORE
40 IF (K .LT. LSIZE) LSTK(K) = LSTK(K+1) - MN
MSTK(K) = M
NSTK(K) = N
LK = LSTK(K)
CALL WCOPY(MN,STKR(L),STKI(L),-1,STKR(LK),STKI(LK),-1)
GO TO 90
C
C VECT(ARG)
50 IF (MSTK(TOP-1) .LT. 0) GO TO 59
MN1 = 1
MN2 = 1
L1 = 0
L2 = 0
IF (N.NE.1 .OR. NK.NE.1) GO TO 52
L1 = LSTK(TOP-1)
M1 = MSTK(TOP-1)
MN1 = M1*NSTK(TOP-1)
M2 = -1
GO TO 60
52 IF (M.NE.1 .OR. MK.NE.1) CALL ERROR(15)
IF (ERR .GT. 0) RETURN
L2 = LSTK(TOP-1)
M2 = MSTK(TOP-1)
MN2 = M2*NSTK(TOP-1)
M1 = -1
GO TO 60
C
C MATRIX(ARG,ARG)
55 IF (MSTK(TOP-1).LT.0 .AND. MSTK(TOP-2).LT.0) GO TO 59
L2 = LSTK(TOP-1)
M2 = MSTK(TOP-1)
MN2 = M2*NSTK(TOP-1)
IF (M2 .LT. 0) MN2 = N
L1 = LSTK(TOP-2)
M1 = MSTK(TOP-2)
MN1 = M1*NSTK(TOP-2)
IF (M1 .LT. 0) MN1 = M
GO TO 60
C
59 IF (MN .NE. MNK) CALL ERROR(15)
IF (ERR .GT. 0) RETURN
LK = LSTK(K)
CALL WCOPY(MN,STKR(L),STKI(L),-1,STKR(LK),STKI(LK),-1)
GO TO 90
C
60 IF (MN1.NE.M .OR. MN2.NE.N) CALL ERROR(15)
IF (ERR .GT. 0) RETURN
LL = 1
IF (M1 .LT. 0) GO TO 62
DO 61 I = 1, MN1
LS = L1+I-1
MK = MAX0(MK,IDINT(STKR(LS)))
LL = MIN0(LL,IDINT(STKR(LS)))
61 CONTINUE
62 MK = MAX0(MK,M)
IF (M2 .LT. 0) GO TO 64
DO 63 I = 1, MN2
LS = L2+I-1
NK = MAX0(NK,IDINT(STKR(LS)))
LL = MIN0(LL,IDINT(STKR(LS)))
63 CONTINUE
64 NK = MAX0(NK,N)
IF (LL .LT. 1) CALL ERROR(21)
IF (ERR .GT. 0) RETURN
MNK = MK*NK
LK = LSTK(K+1) - MNK
ERR = LT + MT*NT - LK
IF (ERR .GT. 0) CALL ERROR(17)
IF (ERR .GT. 0) RETURN
LSTK(K) = LK
MSTK(K) = MK
NSTK(K) = NK
CALL WSET(MNK,0.0D0,0.0D0,STKR(LK),STKI(LK),1)
IF (NT .LT. 1) GO TO 67
DO 66 J = 1, NT
LS = LT+(J-1)*MT
LL = LK+(J-1)*MK
CALL WCOPY(MT,STKR(LS),STKI(LS),-1,STKR(LL),STKI(LL),-1)
66 CONTINUE
67 DO 68 J = 1, N
DO 68 I = 1, M
LI = L1+I-1
IF (M1 .GT. 0) LI = L1 + IDINT(STKR(LI)) - 1
LJ = L2+J-1
IF (M2 .GT. 0) LJ = L2 + IDINT(STKR(LJ)) - 1
LL = LK+LI-L1+(LJ-L2)*MK
LS = L+I-1+(J-1)*M
STKR(LL) = STKR(LS)
STKI(LL) = STKI(LS)
68 CONTINUE
GO TO 90
C
C PRINT IF DESIRED AND POP STACK
90 IF (SYM.NE.SEMI .AND. LCT(3).EQ.0) CALL PRINT(ID,K)
IF (SYM.EQ.SEMI .AND. LCT(3).EQ.1) CALL PRINT(ID,K)
IF (K .EQ. BOT-1) BOT = BOT-1
99 IF (M .NE. 0) TOP = TOP - 1 - RHS
IF (M .EQ. 0) TOP = TOP - 1
RETURN
END
SUBROUTINE TERM
DOUBLE PRECISION STKR(5005),STKI(5005)
INTEGER IDSTK(4,48),LSTK(48),MSTK(48),NSTK(48),VSIZE,LSIZE,BOT,TOP
INTEGER IDS(4,32),PSTK(32),RSTK(32),PSIZE,PT,PTZ
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),HIO,RIO,WIO,RTE,WTE,FE
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /VSTK/ STKR,STKI,IDSTK,LSTK,MSTK,NSTK,VSIZE,LSIZE,BOT,TOP
COMMON /RECU/ IDS,PSTK,RSTK,PSIZE,PT,PTZ
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,HIO,RIO,WIO,RTE,WTE,FE
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
INTEGER R,OP,BSLASH,STAR,SLASH,DOT
DATA BSLASH/45/,STAR/43/,SLASH/44/,DOT/47/
IF (DDT .EQ. 1) WRITE(WTE,100) PT,RSTK(PT)
100 FORMAT(1X,'TERM ',2I4)
R = RSTK(PT)
GO TO (99,99,99,99,99,01,01,05,25,99,99,99,99,99,35,99,99,99,99),R
01 PT = PT+1
RSTK(PT) = 8
C *CALL* FACTOR
RETURN
05 PT = PT-1
10 OP = 0
IF (SYM .EQ. DOT) OP = DOT
IF (SYM .EQ. DOT) CALL GETSYM
IF (SYM.EQ.STAR .OR. SYM.EQ.SLASH .OR. SYM.EQ.BSLASH) GO TO 20
RETURN
20 OP = OP + SYM
CALL GETSYM
IF (SYM .EQ. DOT) OP = OP + SYM
IF (SYM .EQ. DOT) CALL GETSYM
PT = PT+1
PSTK(PT) = OP
RSTK(PT) = 9
C *CALL* FACTOR
RETURN
25 OP = PSTK(PT)
PT = PT-1
CALL STACK2(OP)
IF (ERR .GT. 0) RETURN
C SOME BINARY OPS DONE IN MATFNS
IF (FUN .EQ. 0) GO TO 10
PT = PT+1
RSTK(PT) = 15
C *CALL* MATFN
RETURN
35 PT = PT-1
GO TO 10
99 CALL ERROR(22)
IF (ERR .GT. 0) RETURN
RETURN
END
SUBROUTINE USER(A,M,N,S,T)
DOUBLE PRECISION A(M,N),S,T
C
INTEGER A3(9)
DATA A3 /-149,537,-27,-50,180,-9,-154,546,-25/
IF (A(1,1) .NE. 3.0D0) RETURN
DO 10 I = 1, 9
A(I,1) = DFLOAT(A3(I))
10 CONTINUE
M = 3
N = 3
RETURN
END
SUBROUTINE XCHAR(BUF,K)
INTEGER BUF(1),K
C
C SYSTEM DEPENDENT ROUTINE TO HANDLE SPECIAL CHARACTERS
C
C
INTEGER BACK,MASK
DATA BACK/Z'20202008'/,MASK/Z'000000FF'/
C
IF (BUF(1) .EQ. BACK) K = -1
L = BUF(1) .AND. MASK
IF (K .NE. -1) WRITE(6,10) BUF(1),L
10 FORMAT(1X,1H',A1,4H' = ,Z2,' hex is not a MATLAB character.')
RETURN
END
SUBROUTINE WGECO(AR,AI,LDA,N,IPVT,RCOND,ZR,ZI)
INTEGER LDA,N,IPVT(1)
DOUBLE PRECISION AR(LDA,1),AI(LDA,1),ZR(1),ZI(1)
DOUBLE PRECISION RCOND
C
C WGECO FACTORS A DOUBLE-COMPLEX MATRIX BY GAUSSIAN ELIMINATION
C AND ESTIMATES THE CONDITION OF THE MATRIX.
C
C IF RCOND IS NOT NEEDED, WGEFA IS SLIGHTLY FASTER.
C TO SOLVE A*X = B , FOLLOW WGECO BY WGESL.
C TO COMPUTE INVERSE(A)*C , FOLLOW WGECO BY WGESL.
C TO COMPUTE DETERMINANT(A) , FOLLOW WGECO BY WGEDI.
C TO COMPUTE INVERSE(A) , FOLLOW WGECO BY WGEDI.
C
C ON ENTRY
C
C A DOUBLE-COMPLEX(LDA, N)
C THE MATRIX TO BE FACTORED.
C
C LDA INTEGER
C THE LEADING DIMENSION OF THE ARRAY A .
C
C N INTEGER
C THE ORDER OF THE MATRIX A .
C
C ON RETURN
C
C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C WHICH WERE USED TO OBTAIN IT.
C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE
C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR.
C
C IPVT INTEGER(N)
C AN INTEGER VECTOR OF PIVOT INDICES.
C
C RCOND DOUBLE PRECISION
C AN ESTIMATE OF THE RECIPROCAL CONDITION OF A .
C FOR THE SYSTEM A*X = B , RELATIVE PERTURBATIONS
C IN A AND B OF SIZE EPSILON MAY CAUSE
C RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND .
C IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION
C 1.0 + RCOND .EQ. 1.0
C IS TRUE, THEN A MAY BE SINGULAR TO WORKING
C PRECISION. IN PARTICULAR, RCOND IS ZERO IF
C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
C UNDERFLOWS.
C
C Z DOUBLE-COMPLEX(N)
C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
C IF A IS CLOSE TO A SINGULAR MATRIX, THEN Z IS
C AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C LINPACK. THIS VERSION DATED 07/01/79 .
C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C SUBROUTINES AND FUNCTIONS
C
C LINPACK WGEFA
C BLAS WAXPY,WDOTC,WASUM
C FORTRAN DABS,DMAX1
C
C INTERNAL VARIABLES
C
DOUBLE PRECISION WDOTCR,WDOTCI,EKR,EKI,TR,TI,WKR,WKI,WKMR,WKMI
DOUBLE PRECISION ANORM,S,WASUM,SM,YNORM,FLOP
INTEGER INFO,J,K,KB,KP1,L
C
DOUBLE PRECISION ZDUMR,ZDUMI
DOUBLE PRECISION CABS1
CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
C
C COMPUTE 1-NORM OF A
C
ANORM = 0.0D0
DO 10 J = 1, N
ANORM = DMAX1(ANORM,WASUM(N,AR(1,J),AI(1,J),1))
10 CONTINUE
C
C FACTOR
C
CALL WGEFA(AR,AI,LDA,N,IPVT,INFO)
C
C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND CTRANS(A)*Y = E .
C CTRANS(A) IS THE CONJUGATE TRANSPOSE OF A .
C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C GROWTH IN THE ELEMENTS OF W WHERE CTRANS(U)*W = E .
C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C SOLVE CTRANS(U)*W = E
C
EKR = 1.0D0
EKI = 0.0D0
DO 20 J = 1, N
ZR(J) = 0.0D0
ZI(J) = 0.0D0
20 CONTINUE
DO 110 K = 1, N
CALL WSIGN(EKR,EKI,-ZR(K),-ZI(K),EKR,EKI)
IF (CABS1(EKR-ZR(K),EKI-ZI(K))
* .LE. CABS1(AR(K,K),AI(K,K))) GO TO 40
S = CABS1(AR(K,K),AI(K,K))
* /CABS1(EKR-ZR(K),EKI-ZI(K))
CALL WRSCAL(N,S,ZR,ZI,1)
EKR = S*EKR
EKI = S*EKI
40 CONTINUE
WKR = EKR - ZR(K)
WKI = EKI - ZI(K)
WKMR = -EKR - ZR(K)
WKMI = -EKI - ZI(K)
S = CABS1(WKR,WKI)
SM = CABS1(WKMR,WKMI)
IF (CABS1(AR(K,K),AI(K,K)) .EQ. 0.0D0) GO TO 50
CALL WDIV(WKR,WKI,AR(K,K),-AI(K,K),WKR,WKI)
CALL WDIV(WKMR,WKMI,AR(K,K),-AI(K,K),WKMR,WKMI)
GO TO 60
50 CONTINUE
WKR = 1.0D0
WKI = 0.0D0
WKMR = 1.0D0
WKMI = 0.0D0
60 CONTINUE
KP1 = K + 1
IF (KP1 .GT. N) GO TO 100
DO 70 J = KP1, N
CALL WMUL(WKMR,WKMI,AR(K,J),-AI(K,J),TR,TI)
SM = FLOP(SM + CABS1(ZR(J)+TR,ZI(J)+TI))
CALL WAXPY(1,WKR,WKI,AR(K,J),-AI(K,J),1,
$ ZR(J),ZI(J),1)
S = FLOP(S + CABS1(ZR(J),ZI(J)))
70 CONTINUE
IF (S .GE. SM) GO TO 90
TR = WKMR - WKR
TI = WKMI - WKI
WKR = WKMR
WKI = WKMI
DO 80 J = KP1, N
CALL WAXPY(1,TR,TI,AR(K,J),-AI(K,J),1,
$ ZR(J),ZI(J),1)
80 CONTINUE
90 CONTINUE
100 CONTINUE
ZR(K) = WKR
ZI(K) = WKI
110 CONTINUE
S = 1.0D0/WASUM(N,ZR,ZI,1)
CALL WRSCAL(N,S,ZR,ZI,1)
C
C SOLVE CTRANS(L)*Y = W
C
DO 140 KB = 1, N
K = N + 1 - KB
IF (K .GE. N) GO TO 120
ZR(K) = ZR(K)
* + WDOTCR(N-K,AR(K+1,K),AI(K+1,K),1,ZR(K+1),ZI(K+1),1)
ZI(K) = ZI(K)
* + WDOTCI(N-K,AR(K+1,K),AI(K+1,K),1,ZR(K+1),ZI(K+1),1)
120 CONTINUE
IF (CABS1(ZR(K),ZI(K)) .LE. 1.0D0) GO TO 130
S = 1.0D0/CABS1(ZR(K),ZI(K))
CALL WRSCAL(N,S,ZR,ZI,1)
130 CONTINUE
L = IPVT(K)
TR = ZR(L)
TI = ZI(L)
ZR(L) = ZR(K)
ZI(L) = ZI(K)
ZR(K) = TR
ZI(K) = TI
140 CONTINUE
S = 1.0D0/WASUM(N,ZR,ZI,1)
CALL WRSCAL(N,S,ZR,ZI,1)
C
YNORM = 1.0D0
C
C SOLVE L*V = Y
C
DO 160 K = 1, N
L = IPVT(K)
TR = ZR(L)
TI = ZI(L)
ZR(L) = ZR(K)
ZI(L) = ZI(K)
ZR(K) = TR
ZI(K) = TI
IF (K .LT. N)
* CALL WAXPY(N-K,TR,TI,AR(K+1,K),AI(K+1,K),1,ZR(K+1),ZI(K+1),
* 1)
IF (CABS1(ZR(K),ZI(K)) .LE. 1.0D0) GO TO 150
S = 1.0D0/CABS1(ZR(K),ZI(K))
CALL WRSCAL(N,S,ZR,ZI,1)
YNORM = S*YNORM
150 CONTINUE
160 CONTINUE
S = 1.0D0/WASUM(N,ZR,ZI,1)
CALL WRSCAL(N,S,ZR,ZI,1)
YNORM = S*YNORM
C
C SOLVE U*Z = V
C
DO 200 KB = 1, N
K = N + 1 - KB
IF (CABS1(ZR(K),ZI(K))
* .LE. CABS1(AR(K,K),AI(K,K))) GO TO 170
S = CABS1(AR(K,K),AI(K,K))
* /CABS1(ZR(K),ZI(K))
CALL WRSCAL(N,S,ZR,ZI,1)
YNORM = S*YNORM
170 CONTINUE
IF (CABS1(AR(K,K),AI(K,K)) .EQ. 0.0D0) GO TO 180
CALL WDIV(ZR(K),ZI(K),AR(K,K),AI(K,K),ZR(K),ZI(K))
180 CONTINUE
IF (CABS1(AR(K,K),AI(K,K)) .NE. 0.0D0) GO TO 190
ZR(K) = 1.0D0
ZI(K) = 0.0D0
190 CONTINUE
TR = -ZR(K)
TI = -ZI(K)
CALL WAXPY(K-1,TR,TI,AR(1,K),AI(1,K),1,ZR(1),ZI(1),1)
200 CONTINUE
C MAKE ZNORM = 1.0
S = 1.0D0/WASUM(N,ZR,ZI,1)
CALL WRSCAL(N,S,ZR,ZI,1)
YNORM = S*YNORM
C
IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM
IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0
RETURN
END
SUBROUTINE WGEFA(AR,AI,LDA,N,IPVT,INFO)
INTEGER LDA,N,IPVT(1),INFO
DOUBLE PRECISION AR(LDA,1),AI(LDA,1)
C
C WGEFA FACTORS A DOUBLE-COMPLEX MATRIX BY GAUSSIAN ELIMINATION.
C
C WGEFA IS USUALLY CALLED BY WGECO, BUT IT CAN BE CALLED
C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED.
C (TIME FOR WGECO) = (1 + 9/N)*(TIME FOR WGEFA) .
C
C ON ENTRY
C
C A DOUBLE-COMPLEX(LDA, N)
C THE MATRIX TO BE FACTORED.
C
C LDA INTEGER
C THE LEADING DIMENSION OF THE ARRAY A .
C
C N INTEGER
C THE ORDER OF THE MATRIX A .
C
C ON RETURN
C
C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C WHICH WERE USED TO OBTAIN IT.
C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE
C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR.
C
C IPVT INTEGER(N)
C AN INTEGER VECTOR OF PIVOT INDICES.
C
C INFO INTEGER
C = 0 NORMAL VALUE.
C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR
C CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C INDICATE THAT WGESL OR WGEDI WILL DIVIDE BY ZERO
C IF CALLED. USE RCOND IN WGECO FOR A RELIABLE
C INDICATION OF SINGULARITY.
C
C LINPACK. THIS VERSION DATED 07/01/79 .
C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C SUBROUTINES AND FUNCTIONS
C
C BLAS WAXPY,WSCAL,IWAMAX
C FORTRAN DABS
C
C INTERNAL VARIABLES
C
DOUBLE PRECISION TR,TI
INTEGER IWAMAX,J,K,KP1,L,NM1
C
DOUBLE PRECISION ZDUMR,ZDUMI
DOUBLE PRECISION CABS1
CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
C
C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
INFO = 0
NM1 = N - 1
IF (NM1 .LT. 1) GO TO 70
DO 60 K = 1, NM1
KP1 = K + 1
C
C FIND L = PIVOT INDEX
C
L = IWAMAX(N-K+1,AR(K,K),AI(K,K),1) + K - 1
IPVT(K) = L
C
C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
IF (CABS1(AR(L,K),AI(L,K)) .EQ. 0.0D0) GO TO 40
C
C INTERCHANGE IF NECESSARY
C
IF (L .EQ. K) GO TO 10
TR = AR(L,K)
TI = AI(L,K)
AR(L,K) = AR(K,K)
AI(L,K) = AI(K,K)
AR(K,K) = TR
AI(K,K) = TI
10 CONTINUE
C
C COMPUTE MULTIPLIERS
C
CALL WDIV(-1.0D0,0.0D0,AR(K,K),AI(K,K),TR,TI)
CALL WSCAL(N-K,TR,TI,AR(K+1,K),AI(K+1,K),1)
C
C ROW ELIMINATION WITH COLUMN INDEXING
C
DO 30 J = KP1, N
TR = AR(L,J)
TI = AI(L,J)
IF (L .EQ. K) GO TO 20
AR(L,J) = AR(K,J)
AI(L,J) = AI(K,J)
AR(K,J) = TR
AI(K,J) = TI
20 CONTINUE
CALL WAXPY(N-K,TR,TI,AR(K+1,K),AI(K+1,K),1,AR(K+1,J),
* AI(K+1,J),1)
30 CONTINUE
GO TO 50
40 CONTINUE
INFO = K
50 CONTINUE
60 CONTINUE
70 CONTINUE
IPVT(N) = N
IF (CABS1(AR(N,N),AI(N,N)) .EQ. 0.0D0) INFO = N
RETURN
END
SUBROUTINE WGESL(AR,AI,LDA,N,IPVT,BR,BI,JOB)
INTEGER LDA,N,IPVT(1),JOB
DOUBLE PRECISION AR(LDA,1),AI(LDA,1),BR(1),BI(1)
C
C WGESL SOLVES THE DOUBLE-COMPLEX SYSTEM
C A * X = B OR CTRANS(A) * X = B
C USING THE FACTORS COMPUTED BY WGECO OR WGEFA.
C
C ON ENTRY
C
C A DOUBLE-COMPLEX(LDA, N)
C THE OUTPUT FROM WGECO OR WGEFA.
C
C LDA INTEGER
C THE LEADING DIMENSION OF THE ARRAY A .
C
C N INTEGER
C THE ORDER OF THE MATRIX A .
C
C IPVT INTEGER(N)
C THE PIVOT VECTOR FROM WGECO OR WGEFA.
C
C B DOUBLE-COMPLEX(N)
C THE RIGHT HAND SIDE VECTOR.
C
C JOB INTEGER
C = 0 TO SOLVE A*X = B ,
C = NONZERO TO SOLVE CTRANS(A)*X = B WHERE
C CTRANS(A) IS THE CONJUGATE TRANSPOSE.
C
C ON RETURN
C
C B THE SOLUTION VECTOR X .
C
C ERROR CONDITION
C
C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY
C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE
C CALLED CORRECTLY AND IF WGECO HAS SET RCOND .GT. 0.0
C OR WGEFA HAS SET INFO .EQ. 0 .
C
C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX
C WITH P COLUMNS
C CALL WGECO(A,LDA,N,IPVT,RCOND,Z)
C IF (RCOND IS TOO SMALL) GO TO ...
C DO 10 J = 1, P
C CALL WGESL(A,LDA,N,IPVT,C(1,J),0)
C 10 CONTINUE
C
C LINPACK. THIS VERSION DATED 07/01/79 .
C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C SUBROUTINES AND FUNCTIONS
C
C BLAS WAXPY,WDOTC
C
C INTERNAL VARIABLES
C
DOUBLE PRECISION WDOTCR,WDOTCI,TR,TI
INTEGER K,KB,L,NM1
C
NM1 = N - 1
IF (JOB .NE. 0) GO TO 50
C
C JOB = 0 , SOLVE A * X = B
C FIRST SOLVE L*Y = B
C
IF (NM1 .LT. 1) GO TO 30
DO 20 K = 1, NM1
L = IPVT(K)
TR = BR(L)
TI = BI(L)
IF (L .EQ. K) GO TO 10
BR(L) = BR(K)
BI(L) = BI(K)
BR(K) = TR
BI(K) = TI
10 CONTINUE
CALL WAXPY(N-K,TR,TI,AR(K+1,K),AI(K+1,K),1,BR(K+1),BI(K+1),
* 1)
20 CONTINUE
30 CONTINUE
C
C NOW SOLVE U*X = Y
C
DO 40 KB = 1, N
K = N + 1 - KB
CALL WDIV(BR(K),BI(K),AR(K,K),AI(K,K),BR(K),BI(K))
TR = -BR(K)
TI = -BI(K)
CALL WAXPY(K-1,TR,TI,AR(1,K),AI(1,K),1,BR(1),BI(1),1)
40 CONTINUE
GO TO 100
50 CONTINUE
C
C JOB = NONZERO, SOLVE CTRANS(A) * X = B
C FIRST SOLVE CTRANS(U)*Y = B
C
DO 60 K = 1, N
TR = BR(K) - WDOTCR(K-1,AR(1,K),AI(1,K),1,BR(1),BI(1),1)
TI = BI(K) - WDOTCI(K-1,AR(1,K),AI(1,K),1,BR(1),BI(1),1)
CALL WDIV(TR,TI,AR(K,K),-AI(K,K),BR(K),BI(K))
60 CONTINUE
C
C NOW SOLVE CTRANS(L)*X = Y
C
IF (NM1 .LT. 1) GO TO 90
DO 80 KB = 1, NM1
K = N - KB
BR(K) = BR(K)
* + WDOTCR(N-K,AR(K+1,K),AI(K+1,K),1,BR(K+1),BI(K+1),1)
BI(K) = BI(K)
* + WDOTCI(N-K,AR(K+1,K),AI(K+1,K),1,BR(K+1),BI(K+1),1)
L = IPVT(K)
IF (L .EQ. K) GO TO 70
TR = BR(L)
TI = BI(L)
BR(L) = BR(K)
BI(L) = BI(K)
BR(K) = TR
BI(K) = TI
70 CONTINUE
80 CONTINUE
90 CONTINUE
100 CONTINUE
RETURN
END
SUBROUTINE WGEDI(AR,AI,LDA,N,IPVT,DETR,DETI,WORKR,WORKI,JOB)
INTEGER LDA,N,IPVT(1),JOB
DOUBLE PRECISION AR(LDA,1),AI(LDA,1),DETR(2),DETI(2),WORKR(1),
* WORKI(1)
C
C WGEDI COMPUTES THE DETERMINANT AND INVERSE OF A MATRIX
C USING THE FACTORS COMPUTED BY WGECO OR WGEFA.
C
C ON ENTRY
C
C A DOUBLE-COMPLEX(LDA, N)
C THE OUTPUT FROM WGECO OR WGEFA.
C
C LDA INTEGER
C THE LEADING DIMENSION OF THE ARRAY A .
C
C N INTEGER
C THE ORDER OF THE MATRIX A .
C
C IPVT INTEGER(N)
C THE PIVOT VECTOR FROM WGECO OR WGEFA.
C
C WORK DOUBLE-COMPLEX(N)
C WORK VECTOR. CONTENTS DESTROYED.
C
C JOB INTEGER
C = 11 BOTH DETERMINANT AND INVERSE.
C = 01 INVERSE ONLY.
C = 10 DETERMINANT ONLY.
C
C ON RETURN
C
C A INVERSE OF ORIGINAL MATRIX IF REQUESTED.
C OTHERWISE UNCHANGED.
C
C DET DOUBLE-COMPLEX(2)
C DETERMINANT OF ORIGINAL MATRIX IF REQUESTED.
C OTHERWISE NOT REFERENCED.
C DETERMINANT = DET(1) * 10.0**DET(2)
C WITH 1.0 .LE. CABS1(DET(1) .LT. 10.0
C OR DET(1) .EQ. 0.0 .
C
C ERROR CONDITION
C
C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
C A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED.
C IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY
C AND IF WGECO HAS SET RCOND .GT. 0.0 OR WGEFA HAS SET
C INFO .EQ. 0 .
C
C LINPACK. THIS VERSION DATED 07/01/79 .
C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C SUBROUTINES AND FUNCTIONS
C
C BLAS WAXPY,WSCAL,WSWAP
C FORTRAN DABS,MOD
C
C INTERNAL VARIABLES
C
DOUBLE PRECISION TR,TI
DOUBLE PRECISION TEN
INTEGER I,J,K,KB,KP1,L,NM1
C
DOUBLE PRECISION ZDUMR,ZDUMI
DOUBLE PRECISION CABS1
CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
C
C COMPUTE DETERMINANT
C
IF (JOB/10 .EQ. 0) GO TO 80
DETR(1) = 1.0D0
DETI(1) = 0.0D0
DETR(2) = 0.0D0
DETI(2) = 0.0D0
TEN = 10.0D0
DO 60 I = 1, N
IF (IPVT(I) .EQ. I) GO TO 10
DETR(1) = -DETR(1)
DETI(1) = -DETI(1)
10 CONTINUE
CALL WMUL(AR(I,I),AI(I,I),DETR(1),DETI(1),DETR(1),DETI(1))
C ...EXIT
C ...EXIT
IF (CABS1(DETR(1),DETI(1)) .EQ. 0.0D0) GO TO 70
20 IF (CABS1(DETR(1),DETI(1)) .GE. 1.0D0) GO TO 30
DETR(1) = TEN*DETR(1)
DETI(1) = TEN*DETI(1)
DETR(2) = DETR(2) - 1.0D0
DETI(2) = DETI(2) - 0.0D0
GO TO 20
30 CONTINUE
40 IF (CABS1(DETR(1),DETI(1)) .LT. TEN) GO TO 50
DETR(1) = DETR(1)/TEN
DETI(1) = DETI(1)/TEN
DETR(2) = DETR(2) + 1.0D0
DETI(2) = DETI(2) + 0.0D0
GO TO 40
50 CONTINUE
60 CONTINUE
70 CONTINUE
80 CONTINUE
C
C COMPUTE INVERSE(U)
C
IF (MOD(JOB,10) .EQ. 0) GO TO 160
DO 110 K = 1, N
CALL WDIV(1.0D0,0.0D0,AR(K,K),AI(K,K),AR(K,K),AI(K,K))
TR = -AR(K,K)
TI = -AI(K,K)
CALL WSCAL(K-1,TR,TI,AR(1,K),AI(1,K),1)
KP1 = K + 1
IF (N .LT. KP1) GO TO 100
DO 90 J = KP1, N
TR = AR(K,J)
TI = AI(K,J)
AR(K,J) = 0.0D0
AI(K,J) = 0.0D0
CALL WAXPY(K,TR,TI,AR(1,K),AI(1,K),1,AR(1,J),AI(1,J),1)
90 CONTINUE
100 CONTINUE
110 CONTINUE
C
C FORM INVERSE(U)*INVERSE(L)
C
NM1 = N - 1
IF (NM1 .LT. 1) GO TO 150
DO 140 KB = 1, NM1
K = N - KB
KP1 = K + 1
DO 120 I = KP1, N
WORKR(I) = AR(I,K)
WORKI(I) = AI(I,K)
AR(I,K) = 0.0D0
AI(I,K) = 0.0D0
120 CONTINUE
DO 130 J = KP1, N
TR = WORKR(J)
TI = WORKI(J)
CALL WAXPY(N,TR,TI,AR(1,J),AI(1,J),1,AR(1,K),AI(1,K),1)
130 CONTINUE
L = IPVT(K)
IF (L .NE. K)
* CALL WSWAP(N,AR(1,K),AI(1,K),1,AR(1,L),AI(1,L),1)
140 CONTINUE
150 CONTINUE
160 CONTINUE
RETURN
END
SUBROUTINE WPOFA(AR,AI,LDA,N,INFO)
DOUBLE PRECISION AR(LDA,1),AI(LDA,1)
DOUBLE PRECISION S,TR,TI,WDOTCR,WDOTCI
DO 30 J = 1, N
INFO = J
S = 0.0D0
JM1 = J-1
IF (JM1 .LT. 1) GO TO 20
DO 10 K = 1, JM1
TR = AR(K,J)-WDOTCR(K-1,AR(1,K),AI(1,K),1,AR(1,J),AI(1,J),1)
TI = AI(K,J)-WDOTCI(K-1,AR(1,K),AI(1,K),1,AR(1,J),AI(1,J),1)
CALL WDIV(TR,TI,AR(K,K),AI(K,K),TR,TI)
AR(K,J) = TR
AI(K,J) = TI
S = S + TR*TR + TI*TI
10 CONTINUE
20 CONTINUE
S = AR(J,J) - S
IF (S.LE.0.0D0 .OR. AI(J,J).NE.0.0D0) GO TO 40
AR(J,J) = DSQRT(S)
30 CONTINUE
INFO = 0
40 RETURN
END
SUBROUTINE RREF(AR,AI,LDA,M,N,EPS)
DOUBLE PRECISION AR(LDA,1),AI(LDA,1),EPS,TOL,TR,TI,WASUM
TOL = 0.0D0
DO 10 J = 1, N
TOL = DMAX1(TOL,WASUM(M,AR(1,J),AI(1,J),1))
10 CONTINUE
TOL = EPS*DFLOAT(2*MAX0(M,N))*TOL
K = 1
L = 1
20 IF (K.GT.M .OR. L.GT.N) RETURN
I = IWAMAX(M-K+1,AR(K,L),AI(K,L),1) + K-1
IF (DABS(AR(I,L))+DABS(AI(I,L)) .GT. TOL) GO TO 30
CALL WSET(M-K+1,0.0D0,0.0D0,AR(K,L),AI(K,L),1)
L = L+1
GO TO 20
30 CALL WSWAP(N-L+1,AR(I,L),AI(I,L),LDA,AR(K,L),AI(K,L),LDA)
CALL WDIV(1.0D0,0.0D0,AR(K,L),AI(K,L),TR,TI)
CALL WSCAL(N-L+1,TR,TI,AR(K,L),AI(K,L),LDA)
AR(K,L) = 1.0D0
AI(K,L) = 0.0D0
DO 40 I = 1, M
TR = -AR(I,L)
TI = -AI(I,L)
IF (I .NE. K) CALL WAXPY(N-L+1,TR,TI,
$ AR(K,L),AI(K,L),LDA,AR(I,L),AI(I,L),LDA)
40 CONTINUE
K = K+1
L = L+1
GO TO 20
END
SUBROUTINE HILBER(A,LDA,N)
DOUBLE PRECISION A(LDA,N)
C GENERATE INVERSE HILBERT MATRIX
DOUBLE PRECISION P,R
P = DFLOAT(N)
DO 20 I = 1, N
IF (I.NE.1) P = (DFLOAT(N-I+1)*P*DFLOAT(N+I-1))/DFLOAT(I-1)**2
R = P*P
A(I,I) = R/DFLOAT(2*I-1)
IF (I.EQ.N) GO TO 20
IP1 = I+1
DO 10 J = IP1, N
R = -(DFLOAT(N-J+1)*R*(N+J-1))/DFLOAT(J-1)**2
A(I,J) = R/DFLOAT(I+J-1)
A(J,I) = A(I,J)
10 CONTINUE
20 CONTINUE
RETURN
END
SUBROUTINE HTRIDI(NM,N,AR,AI,D,E,E2,TAU)
C
INTEGER I,J,K,L,N,II,NM,JP1
DOUBLE PRECISION AR(NM,N),AI(NM,N),D(N),E(N),E2(N),TAU(2,N)
DOUBLE PRECISION F,G,H,FI,GI,HH,SI,SCALE
DOUBLE PRECISION FLOP,PYTHAG
C
C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
C THE ALGOL PROCEDURE TRED1, NUM. MATH. 11, 181-195(1968)
C BY MARTIN, REINSCH, AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C THIS SUBROUTINE REDUCES A COMPLEX HERMITIAN MATRIX
C TO A REAL SYMMETRIC TRIDIAGONAL MATRIX USING
C UNITARY SIMILARITY TRANSFORMATIONS.
C
C ON INPUT.
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE COMPLEX HERMITIAN INPUT MATRIX.
C ONLY THE LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
C
C ON OUTPUT.
C
C AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
C FORMATIONS USED IN THE REDUCTION IN THEIR FULL LOWER
C TRIANGLES. THEIR STRICT UPPER TRIANGLES AND THE
C DIAGONAL OF AR ARE UNALTERED.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX.
C
C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO.
C
C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
C
C TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
C
C MODIFIED TO GET RID OF ALL COMPLEX ARITHMETIC, C. MOLER, 6/27/79.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C ------------------------------------------------------------------
C
TAU(1,N) = 1.0D0
TAU(2,N) = 0.0D0
C
DO 100 I = 1, N
100 D(I) = AR(I,I)
C .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
DO 300 II = 1, N
I = N + 1 - II
L = I - 1
H = 0.0D0
SCALE = 0.0D0
IF (L .LT. 1) GO TO 130
C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
DO 120 K = 1, L
120 SCALE = FLOP(SCALE + DABS(AR(I,K)) + DABS(AI(I,K)))
C
IF (SCALE .NE. 0.0D0) GO TO 140
TAU(1,L) = 1.0D0
TAU(2,L) = 0.0D0
130 E(I) = 0.0D0
E2(I) = 0.0D0
GO TO 290
C
140 DO 150 K = 1, L
AR(I,K) = FLOP(AR(I,K)/SCALE)
AI(I,K) = FLOP(AI(I,K)/SCALE)
H = FLOP(H + AR(I,K)*AR(I,K) + AI(I,K)*AI(I,K))
150 CONTINUE
C
E2(I) = FLOP(SCALE*SCALE*H)
G = FLOP(DSQRT(H))
E(I) = FLOP(SCALE*G)
F = PYTHAG(AR(I,L),AI(I,L))
C .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T ..........
IF (F .EQ. 0.0D0) GO TO 160
TAU(1,L) = FLOP((AI(I,L)*TAU(2,I) - AR(I,L)*TAU(1,I))/F)
SI = FLOP((AR(I,L)*TAU(2,I) + AI(I,L)*TAU(1,I))/F)
H = FLOP(H + F*G)
G = FLOP(1.0D0 + G/F)
AR(I,L) = FLOP(G*AR(I,L))
AI(I,L) = FLOP(G*AI(I,L))
IF (L .EQ. 1) GO TO 270
GO TO 170
160 TAU(1,L) = -TAU(1,I)
SI = TAU(2,I)
AR(I,L) = G
170 F = 0.0D0
C
DO 240 J = 1, L
G = 0.0D0
GI = 0.0D0
C .......... FORM ELEMENT OF A*U ..........
DO 180 K = 1, J
G = FLOP(G + AR(J,K)*AR(I,K) + AI(J,K)*AI(I,K))
GI = FLOP(GI - AR(J,K)*AI(I,K) + AI(J,K)*AR(I,K))
180 CONTINUE
C
JP1 = J + 1
IF (L .LT. JP1) GO TO 220
C
DO 200 K = JP1, L
G = FLOP(G + AR(K,J)*AR(I,K) - AI(K,J)*AI(I,K))
GI = FLOP(GI - AR(K,J)*AI(I,K) - AI(K,J)*AR(I,K))
200 CONTINUE
C .......... FORM ELEMENT OF P ..........
220 E(J) = FLOP(G/H)
TAU(2,J) = FLOP(GI/H)
F = FLOP(F + E(J)*AR(I,J) - TAU(2,J)*AI(I,J))
240 CONTINUE
C
HH = FLOP(F/(H + H))
C .......... FORM REDUCED A ..........
DO 260 J = 1, L
F = AR(I,J)
G = FLOP(E(J) - HH*F)
E(J) = G
FI = -AI(I,J)
GI = FLOP(TAU(2,J) - HH*FI)
TAU(2,J) = -GI
C
DO 260 K = 1, J
AR(J,K) = FLOP(AR(J,K) - F*E(K) - G*AR(I,K)
X + FI*TAU(2,K) + GI*AI(I,K))
AI(J,K) = FLOP(AI(J,K) - F*TAU(2,K) - G*AI(I,K)
X - FI*E(K) - GI*AR(I,K))
260 CONTINUE
C
270 DO 280 K = 1, L
AR(I,K) = FLOP(SCALE*AR(I,K))
AI(I,K) = FLOP(SCALE*AI(I,K))
280 CONTINUE
C
TAU(2,L) = -SI
290 HH = D(I)
D(I) = AR(I,I)
AR(I,I) = HH
AI(I,I) = FLOP(SCALE*DSQRT(H))
300 CONTINUE
C
RETURN
END
SUBROUTINE HTRIBK(NM,N,AR,AI,TAU,M,ZR,ZI)
C
INTEGER I,J,K,L,M,N,NM
DOUBLE PRECISION AR(NM,N),AI(NM,N),TAU(2,N),ZR(NM,M),ZI(NM,M)
DOUBLE PRECISION H,S,SI,FLOP
C
C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
C THE ALGOL PROCEDURE TRBAK1, NUM. MATH. 11, 181-195(1968)
C BY MARTIN, REINSCH, AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN
C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
C REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY HTRIDI.
C
C ON INPUT.
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
C FORMATIONS USED IN THE REDUCTION BY HTRIDI IN THEIR
C FULL LOWER TRIANGLES EXCEPT FOR THE DIAGONAL OF AR.
C
C TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
C
C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
C
C ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
C IN ITS FIRST M COLUMNS.
C
C ON OUTPUT.
C
C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
C IN THEIR FIRST M COLUMNS.
C
C NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR
C IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C ------------------------------------------------------------------
C
IF (M .EQ. 0) GO TO 200
C .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC
C TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN
C TRIDIAGONAL MATRIX. ..........
DO 50 K = 1, N
C
DO 50 J = 1, M
ZI(K,J) = FLOP(-ZR(K,J)*TAU(2,K))
ZR(K,J) = FLOP(ZR(K,J)*TAU(1,K))
50 CONTINUE
C
IF (N .EQ. 1) GO TO 200
C .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES ..........
DO 140 I = 2, N
L = I - 1
H = AI(I,I)
IF (H .EQ. 0.0D0) GO TO 140
C
DO 130 J = 1, M
S = 0.0D0
SI = 0.0D0
C
DO 110 K = 1, L
S = FLOP(S + AR(I,K)*ZR(K,J) - AI(I,K)*ZI(K,J))
SI = FLOP(SI + AR(I,K)*ZI(K,J) + AI(I,K)*ZR(K,J))
110 CONTINUE
C .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW ..........
S = FLOP((S/H)/H)
SI = FLOP((SI/H)/H)
C
DO 120 K = 1, L
ZR(K,J) = FLOP(ZR(K,J) - S*AR(I,K) - SI*AI(I,K))
ZI(K,J) = FLOP(ZI(K,J) - SI*AR(I,K) + S*AI(I,K))
120 CONTINUE
C
130 CONTINUE
C
140 CONTINUE
C
200 RETURN
END
SUBROUTINE IMTQL2(NM,N,D,E,Z,IERR,JOB)
C
INTEGER I,J,K,L,M,N,II,NM,MML,IERR
DOUBLE PRECISION D(N),E(N),Z(NM,N)
DOUBLE PRECISION B,C,F,G,P,R,S
DOUBLE PRECISION FLOP
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL2,
C NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON,
C AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
C
C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD.
C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS
C FULL MATRIX TO TRIDIAGONAL FORM.
C
C ON INPUT.
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
C
C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
C
C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS
C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
C THE IDENTITY MATRIX.
C
C ON OUTPUT.
C
C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN
C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
C UNORDERED FOR INDICES 1,2,...,IERR-1.
C
C E HAS BEEN DESTROYED.
C
C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE,
C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
C EIGENVALUES.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C J IF THE J-TH EIGENVALUE HAS NOT BEEN
C DETERMINED AFTER 30 ITERATIONS.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C ------------------------------------------------------------------
C
C
C*****
C MODIFIED BY C. MOLER TO ELIMINATE MACHEP 11/22/78
C MODIFIED TO ADD JOB PARAMETER 08/27/79
C*****
IERR = 0
IF (N .EQ. 1) GO TO 1001
C
DO 100 I = 2, N
100 E(I-1) = E(I)
C
E(N) = 0.0D0
C
DO 240 L = 1, N
J = 0
C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
105 DO 110 M = L, N
IF (M .EQ. N) GO TO 120
C*****
P = FLOP(DABS(D(M)) + DABS(D(M+1)))
S = FLOP(P + DABS(E(M)))
IF (P .EQ. S) GO TO 120
C*****
110 CONTINUE
C
120 P = D(L)
IF (M .EQ. L) GO TO 240
IF (J .EQ. 30) GO TO 1000
J = J + 1
C .......... FORM SHIFT ..........
G = FLOP((D(L+1) - P)/(2.0D0*E(L)))
R = FLOP(DSQRT(G*G+1.0D0))
G = FLOP(D(M) - P + E(L)/(G + DSIGN(R,G)))
S = 1.0D0
C = 1.0D0
P = 0.0D0
MML = M - L
C .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
DO 200 II = 1, MML
I = M - II
F = FLOP(S*E(I))
B = FLOP(C*E(I))
IF (DABS(F) .LT. DABS(G)) GO TO 150
C = FLOP(G/F)
R = FLOP(DSQRT(C*C+1.0D0))
E(I+1) = FLOP(F*R)
S = FLOP(1.0D0/R)
C = FLOP(C*S)
GO TO 160
150 S = FLOP(F/G)
R = FLOP(DSQRT(S*S+1.0D0))
E(I+1) = FLOP(G*R)
C = FLOP(1.0D0/R)
S = FLOP(S*C)
160 G = FLOP(D(I+1) - P)
R = FLOP((D(I) - G)*S + 2.0D0*C*B)
P = FLOP(S*R)
D(I+1) = G + P
G = FLOP(C*R - B)
IF (JOB .EQ. 0) GO TO 185
C .......... FORM VECTOR ..........
DO 180 K = 1, N
F = Z(K,I+1)
Z(K,I+1) = FLOP(S*Z(K,I) + C*F)
Z(K,I) = FLOP(C*Z(K,I) - S*F)
180 CONTINUE
185 CONTINUE
C
200 CONTINUE
C
D(L) = FLOP(D(L) - P)
E(L) = G
E(M) = 0.0D0
GO TO 105
240 CONTINUE
C .......... ORDER EIGENVALUES AND EIGENVECTORS ..........
DO 300 II = 2, N
I = II - 1
K = I
P = D(I)
C
DO 260 J = II, N
IF (D(J) .GE. P) GO TO 260
K = J
P = D(J)
260 CONTINUE
C
IF (K .EQ. I) GO TO 300
D(K) = D(I)
D(I) = P
C
IF (JOB .EQ. 0) GO TO 285
DO 280 J = 1, N
P = Z(J,I)
Z(J,I) = Z(J,K)
Z(J,K) = P
280 CONTINUE
285 CONTINUE
C
300 CONTINUE
C
GO TO 1001
C .......... SET ERROR -- NO CONVERGENCE TO AN
C EIGENVALUE AFTER 30 ITERATIONS ..........
1000 IERR = L
1001 RETURN
END
SUBROUTINE CORTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
C
INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
DOUBLE PRECISION AR(NM,N),AI(NM,N),ORTR(IGH),ORTI(IGH)
DOUBLE PRECISION F,G,H,FI,FR,SCALE
DOUBLE PRECISION FLOP,PYTHAG
C
C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
C BY MARTIN AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
C UNITARY SIMILARITY TRANSFORMATIONS.
C
C ON INPUT.
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
C SET LOW=1, IGH=N.
C
C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
C
C ON OUTPUT.
C
C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
C IS STORED IN THE REMAINING TRIANGLES UNDER THE
C HESSENBERG MATRIX.
C
C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C ------------------------------------------------------------------
C
LA = IGH - 1
KP1 = LOW + 1
IF (LA .LT. KP1) GO TO 200
C
DO 180 M = KP1, LA
H = 0.0D0
ORTR(M) = 0.0D0
ORTI(M) = 0.0D0
SCALE = 0.0D0
C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
DO 90 I = M, IGH
90 SCALE = FLOP(SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1)))
C
IF (SCALE .EQ. 0.0D0) GO TO 180
MP = M + IGH
C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
DO 100 II = M, IGH
I = MP - II
ORTR(I) = FLOP(AR(I,M-1)/SCALE)
ORTI(I) = FLOP(AI(I,M-1)/SCALE)
H = FLOP(H + ORTR(I)*ORTR(I) + ORTI(I)*ORTI(I))
100 CONTINUE
C
G = FLOP(DSQRT(H))
F = PYTHAG(ORTR(M),ORTI(M))
IF (F .EQ. 0.0D0) GO TO 103
H = FLOP(H + F*G)
G = FLOP(G/F)
ORTR(M) = FLOP((1.0D0 + G)*ORTR(M))
ORTI(M) = FLOP((1.0D0 + G)*ORTI(M))
GO TO 105
C
103 ORTR(M) = G
AR(M,M-1) = SCALE
C .......... FORM (I-(U*UT)/H)*A ..........
105 DO 130 J = M, N
FR = 0.0D0
FI = 0.0D0
C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
DO 110 II = M, IGH
I = MP - II
FR = FLOP(FR + ORTR(I)*AR(I,J) + ORTI(I)*AI(I,J))
FI = FLOP(FI + ORTR(I)*AI(I,J) - ORTI(I)*AR(I,J))
110 CONTINUE
C
FR = FLOP(FR/H)
FI = FLOP(FI/H)
C
DO 120 I = M, IGH
AR(I,J) = FLOP(AR(I,J) - FR*ORTR(I) + FI*ORTI(I))
AI(I,J) = FLOP(AI(I,J) - FR*ORTI(I) - FI*ORTR(I))
120 CONTINUE
C
130 CONTINUE
C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
DO 160 I = 1, IGH
FR = 0.0D0
FI = 0.0D0
C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
DO 140 JJ = M, IGH
J = MP - JJ
FR = FLOP(FR + ORTR(J)*AR(I,J) - ORTI(J)*AI(I,J))
FI = FLOP(FI + ORTR(J)*AI(I,J) + ORTI(J)*AR(I,J))
140 CONTINUE
C
FR = FLOP(FR/H)
FI = FLOP(FI/H)
C
DO 150 J = M, IGH
AR(I,J) = FLOP(AR(I,J) - FR*ORTR(J) - FI*ORTI(J))
AI(I,J) = FLOP(AI(I,J) + FR*ORTI(J) - FI*ORTR(J))
150 CONTINUE
C
160 CONTINUE
C
ORTR(M) = FLOP(SCALE*ORTR(M))
ORTI(M) = FLOP(SCALE*ORTI(M))
AR(M,M-1) = FLOP(-G*AR(M,M-1))
AI(M,M-1) = FLOP(-G*AI(M,M-1))
180 CONTINUE
C
200 RETURN
END
SUBROUTINE COMQR3(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR
* ,JOB)
C*****
C MODIFICATION OF EISPACK COMQR2 TO ADD JOB PARAMETER
C JOB = 0 OUTPUT H = SCHUR TRIANGULAR FORM, Z NOT USED
C = 1 OUTPUT H = SCHUR FORM, Z = UNITARY SIMILARITY
C = 2 SAME AS COMQR2
C = 3 OUTPUT H = HESSENBERG FORM, Z = UNITARY SIMILARITY
C ALSO ELIMINATE MACHEP
C C. MOLER, 11/22/78 AND 09/14/80
C OVERFLOW CONTROL IN EIGENVECTOR BACKSUBSTITUTION, 3/16/82
C*****
C
INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N),
X ORTR(IGH),ORTI(IGH)
DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM
DOUBLE PRECISION FLOP,PYTHAG
C
C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
C AND WILKINSON.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
C
C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
C THIS GENERAL MATRIX TO HESSENBERG FORM.
C
C ON INPUT.
C
C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C DIMENSION STATEMENT.
C
C N IS THE ORDER OF THE MATRIX.
C
C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
C SET LOW=1, IGH=N.
C
C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
C
C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
C ARBITRARY.
C
C ON OUTPUT.
C
C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
C HAVE BEEN DESTROYED.
C
C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C FOR INDICES IERR+1,...,N.
C
C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
C THE EIGENVECTORS HAS BEEN FOUND.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C J IF THE J-TH EIGENVALUE HAS NOT BEEN
C DETERMINED AFTER A TOTAL OF 30*N ITERATIONS.
C
C MODIFIED TO GET RID OF ALL COMPLEX ARITHMETIC, C. MOLER, 6/27/79.
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C ------------------------------------------------------------------
C
IERR = 0
C*****
IF (JOB .EQ. 0) GO TO 150
C*****
C .......... INITIALIZE EIGENVECTOR MATRIX ..........
DO 100 I = 1, N
C
DO 100 J = 1, N
ZR(I,J) = 0.0D0
ZI(I,J) = 0.0D0
IF (I .EQ. J) ZR(I,J) = 1.0D0
100 CONTINUE
C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
C FROM THE INFORMATION LEFT BY CORTH ..........
IEND = IGH - LOW - 1
IF (IEND) 180, 150, 105
C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
105 DO 140 II = 1, IEND
I = IGH - II
IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GO TO 140
IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GO TO 140
C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
NORM = FLOP(HR(I,I-1)*ORTR(I) + HI(I,I-1)*ORTI(I))
IP1 = I + 1
C
DO 110 K = IP1, IGH
ORTR(K) = HR(K,I-1)
ORTI(K) = HI(K,I-1)
110 CONTINUE
C
DO 130 J = I, IGH
SR = 0.0D0
SI = 0.0D0
C
DO 115 K = I, IGH
SR = FLOP(SR + ORTR(K)*ZR(K,J) + ORTI(K)*ZI(K,J))
SI = FLOP(SI + ORTR(K)*ZI(K,J) - ORTI(K)*ZR(K,J))
115 CONTINUE
C
SR = FLOP(SR/NORM)
SI = FLOP(SI/NORM)
C
DO 120 K = I, IGH
ZR(K,J) = FLOP(ZR(K,J) + SR*ORTR(K) - SI*ORTI(K))
ZI(K,J) = FLOP(ZI(K,J) + SR*ORTI(K) + SI*ORTR(K))
120 CONTINUE
C
130 CONTINUE
C
140 CONTINUE
C*****
IF (JOB .EQ. 3) GO TO 1001
C*****
C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
150 L = LOW + 1
C
DO 170 I = L, IGH
LL = MIN0(I+1,IGH)
IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170
NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
YR = FLOP(HR(I,I-1)/NORM)
YI = FLOP(HI(I,I-1)/NORM)
HR(I,I-1) = NORM
HI(I,I-1) = 0.0D0
C
DO 155 J = I, N
SI = FLOP(YR*HI(I,J) - YI*HR(I,J))
HR(I,J) = FLOP(YR*HR(I,J) + YI*HI(I,J))
HI(I,J) = SI
155 CONTINUE
C
DO 160 J = 1, LL
SI = FLOP(YR*HI(J,I) + YI*HR(J,I))
HR(J,I) = FLOP(YR*HR(J,I) - YI*HI(J,I))
HI(J,I) = SI
160 CONTINUE
C*****
IF (JOB .EQ. 0) GO TO 170
C*****
DO 165 J = LOW, IGH
SI = FLOP(YR*ZI(J,I) + YI*ZR(J,I))
ZR(J,I) = FLOP(YR*ZR(J,I) - YI*ZI(J,I))
ZI(J,I) = SI
165 CONTINUE
C
170 CONTINUE
C .......... STORE ROOTS ISOLATED BY CBAL ..........
180 DO 200 I = 1, N
IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
WR(I) = HR(I,I)
WI(I) = HI(I,I)
200 CONTINUE
C
EN = IGH
TR = 0.0D0
TI = 0.0D0
ITN = 30*N
C .......... SEARCH FOR NEXT EIGENVALUE ..........
220 IF (EN .LT. LOW) GO TO 680
ITS = 0
ENM1 = EN - 1
C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
240 DO 260 LL = LOW, EN
L = EN + LOW - LL
IF (L .EQ. LOW) GO TO 300
C*****
XR = FLOP(DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
X + DABS(HR(L,L)) +DABS(HI(L,L)))
YR = FLOP(XR + DABS(HR(L,L-1)))
IF (XR .EQ. YR) GO TO 300
C*****
260 CONTINUE
C .......... FORM SHIFT ..........
300 IF (L .EQ. EN) GO TO 660
IF (ITN .EQ. 0) GO TO 1000
IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
SR = HR(EN,EN)
SI = HI(EN,EN)
XR = FLOP(HR(ENM1,EN)*HR(EN,ENM1))
XI = FLOP(HI(ENM1,EN)*HR(EN,ENM1))
IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340
YR = FLOP((HR(ENM1,ENM1) - SR)/2.0D0)
YI = FLOP((HI(ENM1,ENM1) - SI)/2.0D0)
CALL WSQRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
IF (YR*ZZR + YI*ZZI .GE. 0.0D0) GO TO 310
ZZR = -ZZR
ZZI = -ZZI
310 CALL WDIV(XR,XI,YR+ZZR,YI+ZZI,ZZR,ZZI)
SR = FLOP(SR - ZZR)
SI = FLOP(SI - ZZI)
GO TO 340
C .......... FORM EXCEPTIONAL SHIFT ..........
320 SR = FLOP(DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2)))
SI = 0.0D0
C
340 DO 360 I = LOW, EN
HR(I,I) = FLOP(HR(I,I) - SR)
HI(I,I) = FLOP(HI(I,I) - SI)
360 CONTINUE
C
TR = FLOP(TR + SR)
TI = FLOP(TI + SI)
ITS = ITS + 1
ITN = ITN - 1
C .......... REDUCE TO TRIANGLE (ROWS) ..........
LP1 = L + 1
C
DO 500 I = LP1, EN
SR = HR(I,I-1)
HR(I,I-1) = 0.0D0
NORM = FLOP(DABS(HR(I-1,I-1)) + DABS(HI(I-1,I-1)) + DABS(SR))
NORM = FLOP(NORM*DSQRT((HR(I-1,I-1)/NORM)**2 +
X (HI(I-1,I-1)/NORM)**2 + (SR/NORM)**2))
XR = FLOP(HR(I-1,I-1)/NORM)
WR(I-1) = XR
XI = FLOP(HI(I-1,I-1)/NORM)
WI(I-1) = XI
HR(I-1,I-1) = NORM
HI(I-1,I-1) = 0.0D0
HI(I,I-1) = FLOP(SR/NORM)
C
DO 490 J = I, N
YR = HR(I-1,J)
YI = HI(I-1,J)
ZZR = HR(I,J)
ZZI = HI(I,J)
HR(I-1,J) = FLOP(XR*YR + XI*YI + HI(I,I-1)*ZZR)
HI(I-1,J) = FLOP(XR*YI - XI*YR + HI(I,I-1)*ZZI)
HR(I,J) = FLOP(XR*ZZR - XI*ZZI - HI(I,I-1)*YR)
HI(I,J) = FLOP(XR*ZZI + XI*ZZR - HI(I,I-1)*YI)
490 CONTINUE
C
500 CONTINUE
C
SI = HI(EN,EN)
IF (SI .EQ. 0.0D0) GO TO 540
NORM = PYTHAG(HR(EN,EN),SI)
SR = FLOP(HR(EN,EN)/NORM)
SI = FLOP(SI/NORM)
HR(EN,EN) = NORM
HI(EN,EN) = 0.0D0
IF (EN .EQ. N) GO TO 540
IP1 = EN + 1
C
DO 520 J = IP1, N
YR = HR(EN,J)
YI = HI(EN,J)
HR(EN,J) = FLOP(SR*YR + SI*YI)
HI(EN,J) = FLOP(SR*YI - SI*YR)
520 CONTINUE
C .......... INVERSE OPERATION (COLUMNS) ..........
540 DO 600 J = LP1, EN
XR = WR(J-1)
XI = WI(J-1)
C
DO 580 I = 1, J
YR = HR(I,J-1)
YI = 0.0D0
ZZR = HR(I,J)
ZZI = HI(I,J)
IF (I .EQ. J) GO TO 560
YI = HI(I,J-1)
HI(I,J-1) = FLOP(XR*YI + XI*YR + HI(J,J-1)*ZZI)
560 HR(I,J-1) = FLOP(XR*YR - XI*YI + HI(J,J-1)*ZZR)
HR(I,J) = FLOP(XR*ZZR + XI*ZZI - HI(J,J-1)*YR)
HI(I,J) = FLOP(XR*ZZI - XI*ZZR - HI(J,J-1)*YI)
580 CONTINUE
C*****
IF (JOB .EQ. 0) GO TO 600
C*****
DO 590 I = LOW, IGH
YR = ZR(I,J-1)
YI = ZI(I,J-1)
ZZR = ZR(I,J)
ZZI = ZI(I,J)
ZR(I,J-1) = FLOP(XR*YR - XI*YI + HI(J,J-1)*ZZR)
ZI(I,J-1) = FLOP(XR*YI + XI*YR + HI(J,J-1)*ZZI)
ZR(I,J) = FLOP(XR*ZZR + XI*ZZI - HI(J,J-1)*YR)
ZI(I,J) = FLOP(XR*ZZI - XI*ZZR - HI(J,J-1)*YI)
590 CONTINUE
C
600 CONTINUE
C
IF (SI .EQ. 0.0D0) GO TO 240
C
DO 630 I = 1, EN
YR = HR(I,EN)
YI = HI(I,EN)
HR(I,EN) = FLOP(SR*YR - SI*YI)
HI(I,EN) = FLOP(SR*YI + SI*YR)
630 CONTINUE
C*****
IF (JOB .EQ. 0) GO TO 240
C*****
DO 640 I = LOW, IGH
YR = ZR(I,EN)
YI = ZI(I,EN)
ZR(I,EN) = FLOP(SR*YR - SI*YI)
ZI(I,EN) = FLOP(SR*YI + SI*YR)
640 CONTINUE
C
GO TO 240
C .......... A ROOT FOUND ..........
660 HR(EN,EN) = FLOP(HR(EN,EN) + TR)
WR(EN) = HR(EN,EN)
HI(EN,EN) = FLOP(HI(EN,EN) + TI)
WI(EN) = HI(EN,EN)
EN = ENM1
GO TO 220
C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
C VECTORS OF UPPER TRIANGULAR FORM ..........
C
C***** THE FOLLOWING SECTION CHANGED FOR OVERFLOW CONTROL
C C. MOLER, 3/16/82
C
680 IF (JOB .NE. 2) GO TO 1001
C
NORM = 0.0D0
DO 720 I = 1, N
DO 720 J = I, N
TR = FLOP(DABS(HR(I,J))) + FLOP(DABS(HI(I,J)))
IF (TR .GT. NORM) NORM = TR
720 CONTINUE
IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GO TO 1001
C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
DO 800 NN = 2, N
EN = N + 2 - NN
XR = WR(EN)
XI = WI(EN)
HR(EN,EN) = 1.0D0
HI(EN,EN) = 0.0D0
ENM1 = EN - 1
C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
DO 780 II = 1, ENM1
I = EN - II
ZZR = 0.0D0
ZZI = 0.0D0
IP1 = I + 1
DO 740 J = IP1, EN
ZZR = FLOP(ZZR + HR(I,J)*HR(J,EN) - HI(I,J)*HI(J,EN))
ZZI = FLOP(ZZI + HR(I,J)*HI(J,EN) + HI(I,J)*HR(J,EN))
740 CONTINUE
YR = FLOP(XR - WR(I))
YI = FLOP(XI - WI(I))
IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GO TO 765
YR = NORM
760 YR = FLOP(YR/100.0D0)
YI = FLOP(NORM + YR)
IF (YI .NE. NORM) GO TO 760
YI = 0.0D0
765 CONTINUE
CALL WDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
TR = FLOP(DABS(HR(I,EN))) + FLOP(DABS(HI(I,EN)))
IF (TR .EQ. 0.0D0) GO TO 780
IF (TR + 1.0D0/TR .GT. TR) GO TO 780
DO 770 J = I, EN
HR(J,EN) = FLOP(HR(J,EN)/TR)
HI(J,EN) = FLOP(HI(J,EN)/TR)
770 CONTINUE
780 CONTINUE
C
800 CONTINUE
C*****
C .......... END BACKSUBSTITUTION ..........
ENM1 = N - 1
C .......... VECTORS OF ISOLATED ROOTS ..........
DO 840 I = 1, ENM1
IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
IP1 = I + 1
C
DO 820 J = IP1, N
ZR(I,J) = HR(I,J)
ZI(I,J) = HI(I,J)
820 CONTINUE
C
840 CONTINUE
C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
C VECTORS OF ORIGINAL FULL MATRIX.
C FOR J=N STEP -1 UNTIL LOW+1 DO -- ..........
DO 880 JJ = LOW, ENM1
J = N + LOW - JJ
M = MIN0(J,IGH)
C
DO 880 I = LOW, IGH
ZZR = 0.0D0
ZZI = 0.0D0
C
DO 860 K = LOW, M
ZZR = FLOP(ZZR + ZR(I,K)*HR(K,J) - ZI(I,K)*HI(K,J))
ZZI = FLOP(ZZI + ZR(I,K)*HI(K,J) + ZI(I,K)*HR(K,J))
860 CONTINUE
C
ZR(I,J) = ZZR
ZI(I,J) = ZZI
880 CONTINUE
C
GO TO 1001
C .......... SET ERROR -- NO CONVERGENCE TO AN
C EIGENVALUE AFTER 30 ITERATIONS ..........
1000 IERR = EN
1001 RETURN
END
SUBROUTINE WSVDC(XR,XI,LDX,N,P,SR,SI,ER,EI,UR,UI,LDU,VR,VI,LDV,
* WORKR,WORKI,JOB,INFO)
INTEGER LDX,N,P,LDU,LDV,JOB,INFO
DOUBLE PRECISION XR(LDX,1),XI(LDX,1),SR(1),SI(1),ER(1),EI(1),
* UR(LDU,1),UI(LDU,1),VR(LDV,1),VI(LDV,1),
* WORKR(1),WORKI(1)
C
C
C WSVDC IS A SUBROUTINE TO REDUCE A DOUBLE-COMPLEX NXP MATRIX X BY
C UNITARY TRANSFORMATIONS U AND V TO DIAGONAL FORM. THE
C DIAGONAL ELEMENTS S(I) ARE THE SINGULAR VALUES OF X. THE
C COLUMNS OF U ARE THE CORRESPONDING LEFT SINGULAR VECTORS,
C AND THE COLUMNS OF V THE RIGHT SINGULAR VECTORS.
C
C ON ENTRY
C
C X DOUBLE-COMPLEX(LDX,P), WHERE LDX.GE.N.
C X CONTAINS THE MATRIX WHOSE SINGULAR VALUE
C DECOMPOSITION IS TO BE COMPUTED. X IS
C DESTROYED BY WSVDC.
C
C LDX INTEGER.
C LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C
C N INTEGER.
C N IS THE NUMBER OF COLUMNS OF THE MATRIX X.
C
C P INTEGER.
C P IS THE NUMBER OF ROWS OF THE MATRIX X.
C
C LDU INTEGER.
C LDU IS THE LEADING DIMENSION OF THE ARRAY U
C (SEE BELOW).
C
C LDV INTEGER.
C LDV IS THE LEADING DIMENSION OF THE ARRAY V
C (SEE BELOW).
C
C WORK DOUBLE-COMPLEX(N).
C WORK IS A SCRATCH ARRAY.
C
C JOB INTEGER.
C JOB CONTROLS THE COMPUTATION OF THE SINGULAR
C VECTORS. IT HAS THE DECIMAL EXPANSION AB
C WITH THE FOLLOWING MEANING
C
C A.EQ.0 DO NOT COMPUTE THE LEFT SINGULAR
C VECTORS.
C A.EQ.1 RETURN THE N LEFT SINGULAR VECTORS
C IN U.
C A.GE.2 RETURNS THE FIRST MIN(N,P)
C LEFT SINGULAR VECTORS IN U.
C B.EQ.0 DO NOT COMPUTE THE RIGHT SINGULAR
C VECTORS.
C B.EQ.1 RETURN THE RIGHT SINGULAR VECTORS
C IN V.
C
C ON RETURN
C
C S DOUBLE-COMPLEX(MM), WHERE MM=MIN(N+1,P).
C THE FIRST MIN(N,P) ENTRIES OF S CONTAIN THE
C SINGULAR VALUES OF X ARRANGED IN DESCENDING
C ORDER OF MAGNITUDE.
C
C E DOUBLE-COMPLEX(P).
C E ORDINARILY CONTAINS ZEROS. HOWEVER SEE THE
C DISCUSSION OF INFO FOR EXCEPTIONS.
C
C U DOUBLE-COMPLEX(LDU,K), WHERE LDU.GE.N.
C IF JOBA.EQ.1 THEN K.EQ.N,
C IF JOBA.EQ.2 THEN K.EQ.MIN(N,P).
C U CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS.
C U IS NOT REFERENCED IF JOBA.EQ.0. IF N.LE.P
C OR IF JOBA.GT.2, THEN U MAY BE IDENTIFIED WITH X
C IN THE SUBROUTINE CALL.
C
C V DOUBLE-COMPLEX(LDV,P), WHERE LDV.GE.P.
C V CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS.
C V IS NOT REFERENCED IF JOBB.EQ.0. IF P.LE.N,
C THEN V MAY BE IDENTIFIED WHTH X IN THE
C SUBROUTINE CALL.
C
C INFO INTEGER.
C THE SINGULAR VALUES (AND THEIR CORRESPONDING
C SINGULAR VECTORS) S(INFO+1),S(INFO+2),...,S(M)
C ARE CORRECT (HERE M=MIN(N,P)). THUS IF
C INFO.EQ.0, ALL THE SINGULAR VALUES AND THEIR
C VECTORS ARE CORRECT. IN ANY EVENT, THE MATRIX
C B = CTRANS(U)*X*V IS THE BIDIAGONAL MATRIX
C WITH THE ELEMENTS OF S ON ITS DIAGONAL AND THE
C ELEMENTS OF E ON ITS SUPER-DIAGONAL (CTRANS(U)
C IS THE CONJUGATE-TRANSPOSE OF U). THUS THE
C SINGULAR VALUES OF X AND B ARE THE SAME.
C
C LINPACK. THIS VERSION DATED 07/03/79 .
C G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C
C WSVDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
C
C BLAS WAXPY,PYTHAG,WDOTCR,WDOTCI,WSCAL,WSWAP,WNRM2,RROTG
C FORTRAN DABS,DIMAG,DMAX1
C FORTRAN MAX0,MIN0,MOD,DSQRT
C
C INTERNAL VARIABLES
C
INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT,
* MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1
DOUBLE PRECISION PYTHAG,WDOTCR,WDOTCI,TR,TI,RR,RI
DOUBLE PRECISION B,C,CS,EL,EMM1,F,G,WNRM2,SCALE,SHIFT,SL,SM,SN,
* SMM1,T1,TEST,ZTEST,SMALL,FLOP
LOGICAL WANTU,WANTV
C
DOUBLE PRECISION ZDUMR,ZDUMI
DOUBLE PRECISION CABS1
CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
C
C SET THE MAXIMUM NUMBER OF ITERATIONS.
C
MAXIT = 75
C
C SMALL NUMBER, ROUGHLY MACHINE EPSILON, USED TO AVOID UNDERFLOW
C
SMALL = 1.D0/2.D0**48
C
C DETERMINE WHAT IS TO BE COMPUTED.
C
WANTU = .FALSE.
WANTV = .FALSE.
JOBU = MOD(JOB,100)/10
NCU = N
IF (JOBU .GT. 1) NCU = MIN0(N,P)
IF (JOBU .NE. 0) WANTU = .TRUE.
IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE.
C
C REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS
C IN S AND THE SUPER-DIAGONAL ELEMENTS IN E.
C
INFO = 0
NCT = MIN0(N-1,P)
NRT = MAX0(0,MIN0(P-2,N))
LU = MAX0(NCT,NRT)
IF (LU .LT. 1) GO TO 190
DO 180 L = 1, LU
LP1 = L + 1
IF (L .GT. NCT) GO TO 30
C
C COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND
C PLACE THE L-TH DIAGONAL IN S(L).
C
SR(L) = WNRM2(N-L+1,XR(L,L),XI(L,L),1)
SI(L) = 0.0D0
IF (CABS1(SR(L),SI(L)) .EQ. 0.0D0) GO TO 20
IF (CABS1(XR(L,L),XI(L,L)) .EQ. 0.0D0) GO TO 10
CALL WSIGN(SR(L),SI(L),XR(L,L),XI(L,L),SR(L),SI(L))
10 CONTINUE
CALL WDIV(1.0D0,0.0D0,SR(L),SI(L),TR,TI)
CALL WSCAL(N-L+1,TR,TI,XR(L,L),XI(L,L),1)
XR(L,L) = FLOP(1.0D0 + XR(L,L))
20 CONTINUE
SR(L) = -SR(L)
SI(L) = -SI(L)
30 CONTINUE
IF (P .LT. LP1) GO TO 60
DO 50 J = LP1, P
IF (L .GT. NCT) GO TO 40
IF (CABS1(SR(L),SI(L)) .EQ. 0.0D0) GO TO 40
C
C APPLY THE TRANSFORMATION.
C
TR = -WDOTCR(N-L+1,XR(L,L),XI(L,L),1,XR(L,J),XI(L,J),1)
TI = -WDOTCI(N-L+1,XR(L,L),XI(L,L),1,XR(L,J),XI(L,J),1)
CALL WDIV(TR,TI,XR(L,L),XI(L,L),TR,TI)
CALL WAXPY(N-L+1,TR,TI,XR(L,L),XI(L,L),1,XR(L,J),
* XI(L,J),1)
40 CONTINUE
C
C PLACE THE L-TH ROW OF X INTO E FOR THE
C SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION.
C
ER(J) = XR(L,J)
EI(J) = -XI(L,J)
50 CONTINUE
60 CONTINUE
IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 80
C
C PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK
C MULTIPLICATION.
C
DO 70 I = L, N
UR(I,L) = XR(I,L)
UI(I,L) = XI(I,L)
70 CONTINUE
80 CONTINUE
IF (L .GT. NRT) GO TO 170
C
C COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE
C L-TH SUPER-DIAGONAL IN E(L).
C
ER(L) = WNRM2(P-L,ER(LP1),EI(LP1),1)
EI(L) = 0.0D0
IF (CABS1(ER(L),EI(L)) .EQ. 0.0D0) GO TO 100
IF (CABS1(ER(LP1),EI(LP1)) .EQ. 0.0D0) GO TO 90
CALL WSIGN(ER(L),EI(L),ER(LP1),EI(LP1),ER(L),EI(L))
90 CONTINUE
CALL WDIV(1.0D0,0.0D0,ER(L),EI(L),TR,TI)
CALL WSCAL(P-L,TR,TI,ER(LP1),EI(LP1),1)
ER(LP1) = FLOP(1.0D0 + ER(LP1))
100 CONTINUE
ER(L) = -ER(L)
EI(L) = +EI(L)
IF (LP1 .GT. N .OR. CABS1(ER(L),EI(L)) .EQ. 0.0D0)
* GO TO 140
C
C APPLY THE TRANSFORMATION.
C
DO 110 I = LP1, N
WORKR(I) = 0.0D0
WORKI(I) = 0.0D0
110 CONTINUE
DO 120 J = LP1, P
CALL WAXPY(N-L,ER(J),EI(J),XR(LP1,J),XI(LP1,J),1,
* WORKR(LP1),WORKI(LP1),1)
120 CONTINUE
DO 130 J = LP1, P
CALL WDIV(-ER(J),-EI(J),ER(LP1),EI(LP1),TR,TI)
CALL WAXPY(N-L,TR,-TI,WORKR(LP1),WORKI(LP1),1,
* XR(LP1,J),XI(LP1,J),1)
130 CONTINUE
140 CONTINUE
IF (.NOT.WANTV) GO TO 160
C
C PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT
C BACK MULTIPLICATION.
C
DO 150 I = LP1, P
VR(I,L) = ER(I)
VI(I,L) = EI(I)
150 CONTINUE
160 CONTINUE
170 CONTINUE
180 CONTINUE
190 CONTINUE
C
C SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M.
C
M = MIN0(P,N+1)
NCTP1 = NCT + 1
NRTP1 = NRT + 1
IF (NCT .GE. P) GO TO 200
SR(NCTP1) = XR(NCTP1,NCTP1)
SI(NCTP1) = XI(NCTP1,NCTP1)
200 CONTINUE
IF (N .GE. M) GO TO 210
SR(M) = 0.0D0
SI(M) = 0.0D0
210 CONTINUE
IF (NRTP1 .GE. M) GO TO 220
ER(NRTP1) = XR(NRTP1,M)
EI(NRTP1) = XI(NRTP1,M)
220 CONTINUE
ER(M) = 0.0D0
EI(M) = 0.0D0
C
C IF REQUIRED, GENERATE U.
C
IF (.NOT.WANTU) GO TO 350
IF (NCU .LT. NCTP1) GO TO 250
DO 240 J = NCTP1, NCU
DO 230 I = 1, N
UR(I,J) = 0.0D0
UI(I,J) = 0.0D0
230 CONTINUE
UR(J,J) = 1.0D0
UI(J,J) = 0.0D0
240 CONTINUE
250 CONTINUE
IF (NCT .LT. 1) GO TO 340
DO 330 LL = 1, NCT
L = NCT - LL + 1
IF (CABS1(SR(L),SI(L)) .EQ. 0.0D0) GO TO 300
LP1 = L + 1
IF (NCU .LT. LP1) GO TO 270
DO 260 J = LP1, NCU
TR = -WDOTCR(N-L+1,UR(L,L),UI(L,L),1,UR(L,J),
* UI(L,J),1)
TI = -WDOTCI(N-L+1,UR(L,L),UI(L,L),1,UR(L,J),
* UI(L,J),1)
CALL WDIV(TR,TI,UR(L,L),UI(L,L),TR,TI)
CALL WAXPY(N-L+1,TR,TI,UR(L,L),UI(L,L),1,UR(L,J),
* UI(L,J),1)
260 CONTINUE
270 CONTINUE
CALL WRSCAL(N-L+1,-1.0D0,UR(L,L),UI(L,L),1)
UR(L,L) = FLOP(1.0D0 + UR(L,L))
LM1 = L - 1
IF (LM1 .LT. 1) GO TO 290
DO 280 I = 1, LM1
UR(I,L) = 0.0D0
UI(I,L) = 0.0D0
280 CONTINUE
290 CONTINUE
GO TO 320
300 CONTINUE
DO 310 I = 1, N
UR(I,L) = 0.0D0
UI(I,L) = 0.0D0
310 CONTINUE
UR(L,L) = 1.0D0
UI(L,L) = 0.0D0
320 CONTINUE
330 CONTINUE
340 CONTINUE
350 CONTINUE
C
C IF IT IS REQUIRED, GENERATE V.
C
IF (.NOT.WANTV) GO TO 400
DO 390 LL = 1, P
L = P - LL + 1
LP1 = L + 1
IF (L .GT. NRT) GO TO 370
IF (CABS1(ER(L),EI(L)) .EQ. 0.0D0) GO TO 370
DO 360 J = LP1, P
TR = -WDOTCR(P-L,VR(LP1,L),VI(LP1,L),1,VR(LP1,J),
* VI(LP1,J),1)
TI = -WDOTCI(P-L,VR(LP1,L),VI(LP1,L),1,VR(LP1,J),
* VI(LP1,J),1)
CALL WDIV(TR,TI,VR(LP1,L),VI(LP1,L),TR,TI)
CALL WAXPY(P-L,TR,TI,VR(LP1,L),VI(LP1,L),1,VR(LP1,J),
* VI(LP1,J),1)
360 CONTINUE
370 CONTINUE
DO 380 I = 1, P
VR(I,L) = 0.0D0
VI(I,L) = 0.0D0
380 CONTINUE
VR(L,L) = 1.0D0
VI(L,L) = 0.0D0
390 CONTINUE
400 CONTINUE
C
C TRANSFORM S AND E SO THAT THEY ARE REAL.
C
DO 420 I = 1, M
TR = PYTHAG(SR(I),SI(I))
IF (TR .EQ. 0.0D0) GO TO 405
RR = SR(I)/TR
RI = SI(I)/TR
SR(I) = TR
SI(I) = 0.0D0
IF (I .LT. M) CALL WDIV(ER(I),EI(I),RR,RI,ER(I),EI(I))
IF (WANTU) CALL WSCAL(N,RR,RI,UR(1,I),UI(1,I),1)
405 CONTINUE
C ...EXIT
IF (I .EQ. M) GO TO 430
TR = PYTHAG(ER(I),EI(I))
IF (TR .EQ. 0.0D0) GO TO 410
CALL WDIV(TR,0.0D0,ER(I),EI(I),RR,RI)
ER(I) = TR
EI(I) = 0.0D0
CALL WMUL(SR(I+1),SI(I+1),RR,RI,SR(I+1),SI(I+1))
IF (WANTV) CALL WSCAL(P,RR,RI,VR(1,I+1),VI(1,I+1),1)
410 CONTINUE
420 CONTINUE
430 CONTINUE
C
C MAIN ITERATION LOOP FOR THE SINGULAR VALUES.
C
MM = M
ITER = 0
440 CONTINUE
C
C QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND.
C
C ...EXIT
IF (M .EQ. 0) GO TO 700
C
C IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET
C FLAG AND RETURN.
C
IF (ITER .LT. MAXIT) GO TO 450
INFO = M
C ......EXIT
GO TO 700
450 CONTINUE
C
C THIS SECTION OF THE PROGRAM INSPECTS FOR
C NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS. ON
C COMPLETION THE VARIABLE KASE IS SET AS FOLLOWS.
C
C KASE = 1 IF SR(M) AND ER(L-1) ARE NEGLIGIBLE AND L.LT.M
C KASE = 2 IF SR(L) IS NEGLIGIBLE AND L.LT.M
C KASE = 3 IF ER(L-1) IS NEGLIGIBLE, L.LT.M, AND
C SR(L), ..., SR(M) ARE NOT NEGLIGIBLE (QR STEP).
C KASE = 4 IF ER(M-1) IS NEGLIGIBLE (CONVERGENCE).
C
DO 470 LL = 1, M
L = M - LL
C ...EXIT
IF (L .EQ. 0) GO TO 480
TEST = FLOP(DABS(SR(L)) + DABS(SR(L+1)))
ZTEST = FLOP(TEST + DABS(ER(L))/2.0D0)
IF (SMALL*ZTEST .NE. SMALL*TEST) GO TO 460
ER(L) = 0.0D0
C ......EXIT
GO TO 480
460 CONTINUE
470 CONTINUE
480 CONTINUE
IF (L .NE. M - 1) GO TO 490
KASE = 4
GO TO 560
490 CONTINUE
LP1 = L + 1
MP1 = M + 1
DO 510 LLS = LP1, MP1
LS = M - LLS + LP1
C ...EXIT
IF (LS .EQ. L) GO TO 520
TEST = 0.0D0
IF (LS .NE. M) TEST = FLOP(TEST + DABS(ER(LS)))
IF (LS .NE. L + 1) TEST = FLOP(TEST + DABS(ER(LS-1)))
ZTEST = FLOP(TEST + DABS(SR(LS))/2.0D0)
IF (SMALL*ZTEST .NE. SMALL*TEST) GO TO 500
SR(LS) = 0.0D0
C ......EXIT
GO TO 520
500 CONTINUE
510 CONTINUE
520 CONTINUE
IF (LS .NE. L) GO TO 530
KASE = 3
GO TO 550
530 CONTINUE
IF (LS .NE. M) GO TO 540
KASE = 1
GO TO 550
540 CONTINUE
KASE = 2
L = LS
550 CONTINUE
560 CONTINUE
L = L + 1
C
C PERFORM THE TASK INDICATED BY KASE.
C
GO TO (570, 600, 620, 650), KASE
C
C DEFLATE NEGLIGIBLE SR(M).
C
570 CONTINUE
MM1 = M - 1
F = ER(M-1)
ER(M-1) = 0.0D0
DO 590 KK = L, MM1
K = MM1 - KK + L
T1 = SR(K)
CALL RROTG(T1,F,CS,SN)
SR(K) = T1
IF (K .EQ. L) GO TO 580
F = FLOP(-SN*ER(K-1))
ER(K-1) = FLOP(CS*ER(K-1))
580 CONTINUE
IF (WANTV) CALL RROT(P,VR(1,K),1,VR(1,M),1,CS,SN)
IF (WANTV) CALL RROT(P,VI(1,K),1,VI(1,M),1,CS,SN)
590 CONTINUE
GO TO 690
C
C SPLIT AT NEGLIGIBLE SR(L).
C
600 CONTINUE
F = ER(L-1)
ER(L-1) = 0.0D0
DO 610 K = L, M
T1 = SR(K)
CALL RROTG(T1,F,CS,SN)
SR(K) = T1
F = FLOP(-SN*ER(K))
ER(K) = FLOP(CS*ER(K))
IF (WANTU) CALL RROT(N,UR(1,K),1,UR(1,L-1),1,CS,SN)
IF (WANTU) CALL RROT(N,UI(1,K),1,UI(1,L-1),1,CS,SN)
610 CONTINUE
GO TO 690
C
C PERFORM ONE QR STEP.
C
620 CONTINUE
C
C CALCULATE THE SHIFT.
C
SCALE = DMAX1(DABS(SR(M)),DABS(SR(M-1)),DABS(ER(M-1)),
* DABS(SR(L)),DABS(ER(L)))
SM = SR(M)/SCALE
SMM1 = SR(M-1)/SCALE
EMM1 = ER(M-1)/SCALE
SL = SR(L)/SCALE
EL = ER(L)/SCALE
B = FLOP(((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0D0)
C = FLOP((SM*EMM1)**2)
SHIFT = 0.0D0
IF (B .EQ. 0.0D0 .AND. C .EQ. 0.0D0) GO TO 630
SHIFT = FLOP(DSQRT(B**2+C))
IF (B .LT. 0.0D0) SHIFT = -SHIFT
SHIFT = FLOP(C/(B + SHIFT))
630 CONTINUE
F = FLOP((SL + SM)*(SL - SM) - SHIFT)
G = FLOP(SL*EL)
C
C CHASE ZEROS.
C
MM1 = M - 1
DO 640 K = L, MM1
CALL RROTG(F,G,CS,SN)
IF (K .NE. L) ER(K-1) = F
F = FLOP(CS*SR(K) + SN*ER(K))
ER(K) = FLOP(CS*ER(K) - SN*SR(K))
G = FLOP(SN*SR(K+1))
SR(K+1) = FLOP(CS*SR(K+1))
IF (WANTV) CALL RROT(P,VR(1,K),1,VR(1,K+1),1,CS,SN)
IF (WANTV) CALL RROT(P,VI(1,K),1,VI(1,K+1),1,CS,SN)
CALL RROTG(F,G,CS,SN)
SR(K) = F
F = FLOP(CS*ER(K) + SN*SR(K+1))
SR(K+1) = FLOP(-SN*ER(K) + CS*SR(K+1))
G = FLOP(SN*ER(K+1))
ER(K+1) = FLOP(CS*ER(K+1))
IF (WANTU .AND. K .LT. N)
* CALL RROT(N,UR(1,K),1,UR(1,K+1),1,CS,SN)
IF (WANTU .AND. K .LT. N)
* CALL RROT(N,UI(1,K),1,UI(1,K+1),1,CS,SN)
640 CONTINUE
ER(M-1) = F
ITER = ITER + 1
GO TO 690
C
C CONVERGENCE
C
650 CONTINUE
C
C MAKE THE SINGULAR VALUE POSITIVE
C
IF (SR(L) .GE. 0.0D0) GO TO 660
SR(L) = -SR(L)
IF (WANTV) CALL WRSCAL(P,-1.0D0,VR(1,L),VI(1,L),1)
660 CONTINUE
C
C ORDER THE SINGULAR VALUE.
C
670 IF (L .EQ. MM) GO TO 680
C ...EXIT
IF (SR(L) .GE. SR(L+1)) GO TO 680
TR = SR(L)
SR(L) = SR(L+1)
SR(L+1) = TR
IF (WANTV .AND. L .LT. P)
* CALL WSWAP(P,VR(1,L),VI(1,L),1,VR(1,L+1),VI(1,L+1),1)
IF (WANTU .AND. L .LT. N)
* CALL WSWAP(N,UR(1,L),UI(1,L),1,UR(1,L+1),UI(1,L+1),1)
L = L + 1
GO TO 670
680 CONTINUE
ITER = 0
M = M - 1
690 CONTINUE
GO TO 440
700 CONTINUE
RETURN
END
SUBROUTINE WQRDC(XR,XI,LDX,N,P,QRAUXR,QRAUXI,JPVT,WORKR,WORKI,
* JOB)
INTEGER LDX,N,P,JOB
INTEGER JPVT(1)
DOUBLE PRECISION XR(LDX,1),XI(LDX,1),QRAUXR(1),QRAUXI(1),
* WORKR(1),WORKI(1)
C
C WQRDC USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR
C FACTORIZATION OF AN N BY P MATRIX X. COLUMN PIVOTING
C BASED ON THE 2-NORMS OF THE REDUCED COLUMNS MAY BE
C PERFORMED AT THE USERS OPTION.
C
C ON ENTRY
C
C X DOUBLE-COMPLEX(LDX,P), WHERE LDX .GE. N.
C X CONTAINS THE MATRIX WHOSE DECOMPOSITION IS TO BE
C COMPUTED.
C
C LDX INTEGER.
C LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C
C N INTEGER.
C N IS THE NUMBER OF ROWS OF THE MATRIX X.
C
C P INTEGER.
C P IS THE NUMBER OF COLUMNS OF THE MATRIX X.
C
C JPVT INTEGER(P).
C JPVT CONTAINS INTEGERS THAT CONTROL THE SELECTION
C OF THE PIVOT COLUMNS. THE K-TH COLUMN X(K) OF X
C IS PLACED IN ONE OF THREE CLASSES ACCORDING TO THE
C VALUE OF JPVT(K).
C
C IF JPVT(K) .GT. 0, THEN X(K) IS AN INITIAL
C COLUMN.
C
C IF JPVT(K) .EQ. 0, THEN X(K) IS A FREE COLUMN.
C
C IF JPVT(K) .LT. 0, THEN X(K) IS A FINAL COLUMN.
C
C BEFORE THE DECOMPOSITION IS COMPUTED, INITIAL COLUMNS
C ARE MOVED TO THE BEGINNING OF THE ARRAY X AND FINAL
C COLUMNS TO THE END. BOTH INITIAL AND FINAL COLUMNS
C ARE FROZEN IN PLACE DURING THE COMPUTATION AND ONLY
C FREE COLUMNS ARE MOVED. AT THE K-TH STAGE OF THE
C REDUCTION, IF X(K) IS OCCUPIED BY A FREE COLUMN
C IT IS INTERCHANGED WITH THE FREE COLUMN OF LARGEST
C REDUCED NORM. JPVT IS NOT REFERENCED IF
C JOB .EQ. 0.
C
C WORK DOUBLE-COMPLEX(P).
C WORK IS A WORK ARRAY. WORK IS NOT REFERENCED IF
C JOB .EQ. 0.
C
C JOB INTEGER.
C JOB IS AN INTEGER THAT INITIATES COLUMN PIVOTING.
C IF JOB .EQ. 0, NO PIVOTING IS DONE.
C IF JOB .NE. 0, PIVOTING IS DONE.
C
C ON RETURN
C
C X X CONTAINS IN ITS UPPER TRIANGLE THE UPPER
C TRIANGULAR MATRIX R OF THE QR FACTORIZATION.
C BELOW ITS DIAGONAL X CONTAINS INFORMATION FROM
C WHICH THE UNITARY PART OF THE DECOMPOSITION
C CAN BE RECOVERED. NOTE THAT IF PIVOTING HAS
C BEEN REQUESTED, THE DECOMPOSITION IS NOT THAT
C OF THE ORIGINAL MATRIX X BUT THAT OF X
C WITH ITS COLUMNS PERMUTED AS DESCRIBED BY JPVT.
C
C QRAUX DOUBLE-COMPLEX(P).
C QRAUX CONTAINS FURTHER INFORMATION REQUIRED TO RECOVER
C THE UNITARY PART OF THE DECOMPOSITION.
C
C JPVT JPVT(K) CONTAINS THE INDEX OF THE COLUMN OF THE
C ORIGINAL MATRIX THAT HAS BEEN INTERCHANGED INTO
C THE K-TH COLUMN, IF PIVOTING WAS REQUESTED.
C
C LINPACK. THIS VERSION DATED 07/03/79 .
C G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C
C WQRDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
C
C BLAS WAXPY,PYTHAG,WDOTCR,WDOTCI,WSCAL,WSWAP,WNRM2
C FORTRAN DABS,DIMAG,DMAX1,MIN0
C
C INTERNAL VARIABLES
C
INTEGER J,JP,L,LP1,LUP,MAXJ,PL,PU
DOUBLE PRECISION MAXNRM,WNRM2,TT
DOUBLE PRECISION PYTHAG,WDOTCR,WDOTCI,NRMXLR,NRMXLI,TR,TI,FLOP
LOGICAL NEGJ,SWAPJ
C
DOUBLE PRECISION ZDUMR,ZDUMI
DOUBLE PRECISION CABS1
CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
C
PL = 1
PU = 0
IF (JOB .EQ. 0) GO TO 60
C
C PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS
C ACCORDING TO JPVT.
C
DO 20 J = 1, P
SWAPJ = JPVT(J) .GT. 0
NEGJ = JPVT(J) .LT. 0
JPVT(J) = J
IF (NEGJ) JPVT(J) = -J
IF (.NOT.SWAPJ) GO TO 10
IF (J .NE. PL)
* CALL WSWAP(N,XR(1,PL),XI(1,PL),1,XR(1,J),XI(1,J),1)
JPVT(J) = JPVT(PL)
JPVT(PL) = J
PL = PL + 1
10 CONTINUE
20 CONTINUE
PU = P
DO 50 JJ = 1, P
J = P - JJ + 1
IF (JPVT(J) .GE. 0) GO TO 40
JPVT(J) = -JPVT(J)
IF (J .EQ. PU) GO TO 30
CALL WSWAP(N,XR(1,PU),XI(1,PU),1,XR(1,J),XI(1,J),1)
JP = JPVT(PU)
JPVT(PU) = JPVT(J)
JPVT(J) = JP
30 CONTINUE
PU = PU - 1
40 CONTINUE
50 CONTINUE
60 CONTINUE
C
C COMPUTE THE NORMS OF THE FREE COLUMNS.
C
IF (PU .LT. PL) GO TO 80
DO 70 J = PL, PU
QRAUXR(J) = WNRM2(N,XR(1,J),XI(1,J),1)
QRAUXI(J) = 0.0D0
WORKR(J) = QRAUXR(J)
WORKI(J) = QRAUXI(J)
70 CONTINUE
80 CONTINUE
C
C PERFORM THE HOUSEHOLDER REDUCTION OF X.
C
LUP = MIN0(N,P)
DO 210 L = 1, LUP
IF (L .LT. PL .OR. L .GE. PU) GO TO 120
C
C LOCATE THE COLUMN OF LARGEST NORM AND BRING IT
C INTO THE PIVOT POSITION.
C
MAXNRM = 0.0D0
MAXJ = L
DO 100 J = L, PU
IF (QRAUXR(J) .LE. MAXNRM) GO TO 90
MAXNRM = QRAUXR(J)
MAXJ = J
90 CONTINUE
100 CONTINUE
IF (MAXJ .EQ. L) GO TO 110
CALL WSWAP(N,XR(1,L),XI(1,L),1,XR(1,MAXJ),XI(1,MAXJ),1)
QRAUXR(MAXJ) = QRAUXR(L)
QRAUXI(MAXJ) = QRAUXI(L)
WORKR(MAXJ) = WORKR(L)
WORKI(MAXJ) = WORKI(L)
JP = JPVT(MAXJ)
JPVT(MAXJ) = JPVT(L)
JPVT(L) = JP
110 CONTINUE
120 CONTINUE
QRAUXR(L) = 0.0D0
QRAUXI(L) = 0.0D0
IF (L .EQ. N) GO TO 200
C
C COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L.
C
NRMXLR = WNRM2(N-L+1,XR(L,L),XI(L,L),1)
NRMXLI = 0.0D0
IF (CABS1(NRMXLR,NRMXLI) .EQ. 0.0D0) GO TO 190
IF (CABS1(XR(L,L),XI(L,L)) .EQ. 0.0D0) GO TO 130
CALL WSIGN(NRMXLR,NRMXLI,XR(L,L),XI(L,L),NRMXLR,NRMXLI)
130 CONTINUE
CALL WDIV(1.0D0,0.0D0,NRMXLR,NRMXLI,TR,TI)
CALL WSCAL(N-L+1,TR,TI,XR(L,L),XI(L,L),1)
XR(L,L) = FLOP(1.0D0 + XR(L,L))
C
C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS,
C UPDATING THE NORMS.
C
LP1 = L + 1
IF (P .LT. LP1) GO TO 180
DO 170 J = LP1, P
TR = -WDOTCR(N-L+1,XR(L,L),XI(L,L),1,XR(L,J),
* XI(L,J),1)
TI = -WDOTCI(N-L+1,XR(L,L),XI(L,L),1,XR(L,J),
* XI(L,J),1)
CALL WDIV(TR,TI,XR(L,L),XI(L,L),TR,TI)
CALL WAXPY(N-L+1,TR,TI,XR(L,L),XI(L,L),1,XR(L,J),
* XI(L,J),1)
IF (J .LT. PL .OR. J .GT. PU) GO TO 160
IF (CABS1(QRAUXR(J),QRAUXI(J)) .EQ. 0.0D0)
* GO TO 160
TT = 1.0D0 - (PYTHAG(XR(L,J),XI(L,J))/QRAUXR(J))**2
TT = DMAX1(TT,0.0D0)
TR = FLOP(TT)
TT = FLOP(1.0D0+0.05D0*TT*(QRAUXR(J)/WORKR(J))**2)
IF (TT .EQ. 1.0D0) GO TO 140
QRAUXR(J) = QRAUXR(J)*DSQRT(TR)
QRAUXI(J) = QRAUXI(J)*DSQRT(TR)
GO TO 150
140 CONTINUE
QRAUXR(J) = WNRM2(N-L,XR(L+1,J),XI(L+1,J),1)
QRAUXI(J) = 0.0D0
WORKR(J) = QRAUXR(J)
WORKI(J) = QRAUXI(J)
150 CONTINUE
160 CONTINUE
170 CONTINUE
180 CONTINUE
C
C SAVE THE TRANSFORMATION.
C
QRAUXR(L) = XR(L,L)
QRAUXI(L) = XI(L,L)
XR(L,L) = -NRMXLR
XI(L,L) = -NRMXLI
190 CONTINUE
200 CONTINUE
210 CONTINUE
RETURN
END
SUBROUTINE WQRSL(XR,XI,LDX,N,K,QRAUXR,QRAUXI,YR,YI,QYR,QYI,QTYR,
* QTYI,BR,BI,RSDR,RSDI,XBR,XBI,JOB,INFO)
INTEGER LDX,N,K,JOB,INFO
DOUBLE PRECISION XR(LDX,1),XI(LDX,1),QRAUXR(1),QRAUXI(1),YR(1),
* YI(1),QYR(1),QYI(1),QTYR(1),QTYI(1),BR(1),BI(1),
* RSDR(1),RSDI(1),XBR(1),XBI(1)
C
C WQRSL APPLIES THE OUTPUT OF WQRDC TO COMPUTE COORDINATE
C TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS.
C FOR K .LE. MIN(N,P), LET XK BE THE MATRIX
C
C XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K)))
C
C FORMED FROM COLUMNNS JPVT(1), ... ,JPVT(K) OF THE ORIGINAL
C N X P MATRIX X THAT WAS INPUT TO WQRDC (IF NO PIVOTING WAS
C DONE, XK CONSISTS OF THE FIRST K COLUMNS OF X IN THEIR
C ORIGINAL ORDER). WQRDC PRODUCES A FACTORED UNITARY MATRIX Q
C AND AN UPPER TRIANGULAR MATRIX R SUCH THAT
C
C XK = Q * (R)
C (0)
C
C THIS INFORMATION IS CONTAINED IN CODED FORM IN THE ARRAYS
C X AND QRAUX.
C
C ON ENTRY
C
C X DOUBLE-COMPLEX(LDX,P).
C X CONTAINS THE OUTPUT OF WQRDC.
C
C LDX INTEGER.
C LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C
C N INTEGER.
C N IS THE NUMBER OF ROWS OF THE MATRIX XK. IT MUST
C HAVE THE SAME VALUE AS N IN WQRDC.
C
C K INTEGER.
C K IS THE NUMBER OF COLUMNS OF THE MATRIX XK. K
C MUST NNOT BE GREATER THAN MIN(N,P), WHERE P IS THE
C SAME AS IN THE CALLING SEQUENCE TO WQRDC.
C
C QRAUX DOUBLE-COMPLEX(P).
C QRAUX CONTAINS THE AUXILIARY OUTPUT FROM WQRDC.
C
C Y DOUBLE-COMPLEX(N)
C Y CONTAINS AN N-VECTOR THAT IS TO BE MANIPULATED
C BY WQRSL.
C
C JOB INTEGER.
C JOB SPECIFIES WHAT IS TO BE COMPUTED. JOB HAS
C THE DECIMAL EXPANSION ABCDE, WITH THE FOLLOWING
C MEANING.
C
C IF A.NE.0, COMPUTE QY.
C IF B,C,D, OR E .NE. 0, COMPUTE QTY.
C IF C.NE.0, COMPUTE B.
C IF D.NE.0, COMPUTE RSD.
C IF E.NE.0, COMPUTE XB.
C
C NOTE THAT A REQUEST TO COMPUTE B, RSD, OR XB
C AUTOMATICALLY TRIGGERS THE COMPUTATION OF QTY, FOR
C WHICH AN ARRAY MUST BE PROVIDED IN THE CALLING
C SEQUENCE.
C
C ON RETURN
C
C QY DOUBLE-COMPLEX(N).
C QY CONNTAINS Q*Y, IF ITS COMPUTATION HAS BEEN
C REQUESTED.
C
C QTY DOUBLE-COMPLEX(N).
C QTY CONTAINS CTRANS(Q)*Y, IF ITS COMPUTATION HAS
C BEEN REQUESTED. HERE CTRANS(Q) IS THE CONJUGATE
C TRANSPOSE OF THE MATRIX Q.
C
C B DOUBLE-COMPLEX(K)
C B CONTAINS THE SOLUTION OF THE LEAST SQUARES PROBLEM
C
C MINIMIZE NORM2(Y - XK*B),
C
C IF ITS COMPUTATION HAS BEEN REQUESTED. (NOTE THAT
C IF PIVOTING WAS REQUESTED IN WQRDC, THE J-TH
C COMPONENT OF B WILL BE ASSOCIATED WITH COLUMN JPVT(J)
C OF THE ORIGINAL MATRIX X THAT WAS INPUT INTO WQRDC.)
C
C RSD DOUBLE-COMPLEX(N).
C RSD CONTAINS THE LEAST SQUARES RESIDUAL Y - XK*B,
C IF ITS COMPUTATION HAS BEEN REQUESTED. RSD IS
C ALSO THE ORTHOGONAL PROJECTION OF Y ONTO THE
C ORTHOGONAL COMPLEMENT OF THE COLUMN SPACE OF XK.
C
C XB DOUBLE-COMPLEX(N).
C XB CONTAINS THE LEAST SQUARES APPROXIMATION XK*B,
C IF ITS COMPUTATION HAS BEEN REQUESTED. XB IS ALSO
C THE ORTHOGONAL PROJECTION OF Y ONTO THE COLUMN SPACE
C OF X.
C
C INFO INTEGER.
C INFO IS ZERO UNLESS THE COMPUTATION OF B HAS
C BEEN REQUESTED AND R IS EXACTLY SINGULAR. IN
C THIS CASE, INFO IS THE INDEX OF THE FIRST ZERO
C DIAGONAL ELEMENT OF R AND B IS LEFT UNALTERED.
C
C THE PARAMETERS QY, QTY, B, RSD, AND XB ARE NOT REFERENCED
C IF THEIR COMPUTATION IS NOT REQUESTED AND IN THIS CASE
C CAN BE REPLACED BY DUMMY VARIABLES IN THE CALLING PROGRAM.
C TO SAVE STORAGE, THE USER MAY IN SOME CASES USE THE SAME
C ARRAY FOR DIFFERENT PARAMETERS IN THE CALLING SEQUENCE. A
C FREQUENTLY OCCURING EXAMPLE IS WHEN ONE WISHES TO COMPUTE
C ANY OF B, RSD, OR XB AND DOES NOT NEED Y OR QTY. IN THIS
C CASE ONE MAY IDENTIFY Y, QTY, AND ONE OF B, RSD, OR XB, WHILE
C PROVIDING SEPARATE ARRAYS FOR ANYTHING ELSE THAT IS TO BE
C COMPUTED. THUS THE CALLING SEQUENCE
C
C CALL WQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO)
C
C WILL RESULT IN THE COMPUTATION OF B AND RSD, WITH RSD
C OVERWRITING Y. MORE GENERALLY, EACH ITEM IN THE FOLLOWING
C LIST CONTAINS GROUPS OF PERMISSIBLE IDENTIFICATIONS FOR
C A SINGLE CALLINNG SEQUENCE.
C
C 1. (Y,QTY,B) (RSD) (XB) (QY)
C
C 2. (Y,QTY,RSD) (B) (XB) (QY)
C
C 3. (Y,QTY,XB) (B) (RSD) (QY)
C
C 4. (Y,QY) (QTY,B) (RSD) (XB)
C
C 5. (Y,QY) (QTY,RSD) (B) (XB)
C
C 6. (Y,QY) (QTY,XB) (B) (RSD)
C
C IN ANY GROUP THE VALUE RETURNED IN THE ARRAY ALLOCATED TO
C THE GROUP CORRESPONDS TO THE LAST MEMBER OF THE GROUP.
C
C LINPACK. THIS VERSION DATED 07/03/79 .
C G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C
C WQRSL USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
C
C BLAS WAXPY,WCOPY,WDOTCR,WDOTCI
C FORTRAN DABS,DIMAG,MIN0,MOD
C
C INTERNAL VARIABLES
C
INTEGER I,J,JJ,JU,KP1
DOUBLE PRECISION WDOTCR,WDOTCI,TR,TI,TEMPR,TEMPI
LOGICAL CB,CQY,CQTY,CR,CXB
C
DOUBLE PRECISION ZDUMR,ZDUMI
DOUBLE PRECISION CABS1
CABS1(ZDUMR,ZDUMI) = DABS(ZDUMR) + DABS(ZDUMI)
C
C SET INFO FLAG.
C
INFO = 0
C
C DETERMINE WHAT IS TO BE COMPUTED.
C
CQY = JOB/10000 .NE. 0
CQTY = MOD(JOB,10000) .NE. 0
CB = MOD(JOB,1000)/100 .NE. 0
CR = MOD(JOB,100)/10 .NE. 0
CXB = MOD(JOB,10) .NE. 0
JU = MIN0(K,N-1)
C
C SPECIAL ACTION WHEN N=1.
C
IF (JU .NE. 0) GO TO 80
IF (.NOT.CQY) GO TO 10
QYR(1) = YR(1)
QYI(1) = YI(1)
10 CONTINUE
IF (.NOT.CQTY) GO TO 20
QTYR(1) = YR(1)
QTYI(1) = YI(1)
20 CONTINUE
IF (.NOT.CXB) GO TO 30
XBR(1) = YR(1)
XBI(1) = YI(1)
30 CONTINUE
IF (.NOT.CB) GO TO 60
IF (CABS1(XR(1,1),XI(1,1)) .NE. 0.0D0) GO TO 40
INFO = 1
GO TO 50
40 CONTINUE
CALL WDIV(YR(1),YI(1),XR(1,1),XI(1,1),BR(1),BI(1))
50 CONTINUE
60 CONTINUE
IF (.NOT.CR) GO TO 70
RSDR(1) = 0.0D0
RSDI(1) = 0.0D0
70 CONTINUE
GO TO 290
80 CONTINUE
C
C SET UP TO COMPUTE QY OR QTY.
C
IF (CQY) CALL WCOPY(N,YR,YI,1,QYR,QYI,1)
IF (CQTY) CALL WCOPY(N,YR,YI,1,QTYR,QTYI,1)
IF (.NOT.CQY) GO TO 110
C
C COMPUTE QY.
C
DO 100 JJ = 1, JU
J = JU - JJ + 1
IF (CABS1(QRAUXR(J),QRAUXI(J)) .EQ. 0.0D0)
* GO TO 90
TEMPR = XR(J,J)
TEMPI = XI(J,J)
XR(J,J) = QRAUXR(J)
XI(J,J) = QRAUXI(J)
TR = -WDOTCR(N-J+1,XR(J,J),XI(J,J),1,QYR(J),QYI(J),1)
TI = -WDOTCI(N-J+1,XR(J,J),XI(J,J),1,QYR(J),QYI(J),1)
CALL WDIV(TR,TI,XR(J,J),XI(J,J),TR,TI)
CALL WAXPY(N-J+1,TR,TI,XR(J,J),XI(J,J),1,QYR(J),
* QYI(J),1)
XR(J,J) = TEMPR
XI(J,J) = TEMPI
90 CONTINUE
100 CONTINUE
110 CONTINUE
IF (.NOT.CQTY) GO TO 140
C
C COMPUTE CTRANS(Q)*Y.
C
DO 130 J = 1, JU
IF (CABS1(QRAUXR(J),QRAUXI(J)) .EQ. 0.0D0)
* GO TO 120
TEMPR = XR(J,J)
TEMPI = XI(J,J)
XR(J,J) = QRAUXR(J)
XI(J,J) = QRAUXI(J)
TR = -WDOTCR(N-J+1,XR(J,J),XI(J,J),1,QTYR(J),
* QTYI(J),1)
TI = -WDOTCI(N-J+1,XR(J,J),XI(J,J),1,QTYR(J),
* QTYI(J),1)
CALL WDIV(TR,TI,XR(J,J),XI(J,J),TR,TI)
CALL WAXPY(N-J+1,TR,TI,XR(J,J),XI(J,J),1,QTYR(J),
* QTYI(J),1)
XR(J,J) = TEMPR
XI(J,J) = TEMPI
120 CONTINUE
130 CONTINUE
140 CONTINUE
C
C SET UP TO COMPUTE B, RSD, OR XB.
C
IF (CB) CALL WCOPY(K,QTYR,QTYI,1,BR,BI,1)
KP1 = K + 1
IF (CXB) CALL WCOPY(K,QTYR,QTYI,1,XBR,XBI,1)
IF (CR .AND. K .LT. N)
* CALL WCOPY(N-K,QTYR(KP1),QTYI(KP1),1,RSDR(KP1),RSDI(KP1),1)
IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 160
DO 150 I = KP1, N
XBR(I) = 0.0D0
XBI(I) = 0.0D0
150 CONTINUE
160 CONTINUE
IF (.NOT.CR) GO TO 180
DO 170 I = 1, K
RSDR(I) = 0.0D0
RSDI(I) = 0.0D0
170 CONTINUE
180 CONTINUE
IF (.NOT.CB) GO TO 230
C
C COMPUTE B.
C
DO 210 JJ = 1, K
J = K - JJ + 1
IF (CABS1(XR(J,J),XI(J,J)) .NE. 0.0D0) GO TO 190
INFO = J
C ......EXIT
C ......EXIT
GO TO 220
190 CONTINUE
CALL WDIV(BR(J),BI(J),XR(J,J),XI(J,J),BR(J),BI(J))
IF (J .EQ. 1) GO TO 200
TR = -BR(J)
TI = -BI(J)
CALL WAXPY(J-1,TR,TI,XR(1,J),XI(1,J),1,BR,BI,1)
200 CONTINUE
210 CONTINUE
220 CONTINUE
230 CONTINUE
IF (.NOT.CR .AND. .NOT.CXB) GO TO 280
C
C COMPUTE RSD OR XB AS REQUIRED.
C
DO 270 JJ = 1, JU
J = JU - JJ + 1
IF (CABS1(QRAUXR(J),QRAUXI(J)) .EQ. 0.0D0)
* GO TO 260
TEMPR = XR(J,J)
TEMPI = XI(J,J)
XR(J,J) = QRAUXR(J)
XI(J,J) = QRAUXI(J)
IF (.NOT.CR) GO TO 240
TR = -WDOTCR(N-J+1,XR(J,J),XI(J,J),1,RSDR(J),
* RSDI(J),1)
TI = -WDOTCI(N-J+1,XR(J,J),XI(J,J),1,RSDR(J),
* RSDI(J),1)
CALL WDIV(TR,TI,XR(J,J),XI(J,J),TR,TI)
CALL WAXPY(N-J+1,TR,TI,XR(J,J),XI(J,J),1,RSDR(J),
* RSDI(J),1)
240 CONTINUE
IF (.NOT.CXB) GO TO 250
TR = -WDOTCR(N-J+1,XR(J,J),XI(J,J),1,XBR(J),
* XBI(J),1)
TI = -WDOTCI(N-J+1,XR(J,J),XI(J,J),1,XBR(J),
* XBI(J),1)
CALL WDIV(TR,TI,XR(J,J),XI(J,J),TR,TI)
CALL WAXPY(N-J+1,TR,TI,XR(J,J),XI(J,J),1,XBR(J),
* XBI(J),1)
250 CONTINUE
XR(J,J) = TEMPR
XI(J,J) = TEMPI
260 CONTINUE
270 CONTINUE
280 CONTINUE
290 CONTINUE
RETURN
END
SUBROUTINE MAGIC(A,LDA,N)
C
C ALGORITHMS FOR MAGIC SQUARES TAKEN FROM
C MATHEMATICAL RECREATIONS AND ESSAYS, 12TH ED.,
C BY W. W. ROUSE BALL AND H. S. M. COXETER
C
DOUBLE PRECISION A(LDA,N),T
C
IF (MOD(N,4) .EQ. 0) GO TO 100
IF (MOD(N,2) .EQ. 0) M = N/2
IF (MOD(N,2) .NE. 0) M = N
C
C ODD ORDER OR UPPER CORNER OF EVEN ORDER
C
DO 20 J = 1,M
DO 10 I = 1,M
A(I,J) = 0
10 CONTINUE
20 CONTINUE
I = 1
J = (M+1)/2
MM = M*M
DO 40 K = 1, MM
A(I,J) = K
I1 = I-1
J1 = J+1
IF(I1.LT.1) I1 = M
IF(J1.GT.M) J1 = 1
IF(IDINT(A(I1,J1)).EQ.0) GO TO 30
I1 = I+1
J1 = J
30 I = I1
J = J1
40 CONTINUE
IF (MOD(N,2) .NE. 0) RETURN
C
C REST OF EVEN ORDER
C
T = M*M
DO 60 I = 1, M
DO 50 J = 1, M
IM = I+M
JM = J+M
A(I,JM) = A(I,J) + 2*T
A(IM,J) = A(I,J) + 3*T
A(IM,JM) = A(I,J) + T
50 CONTINUE
60 CONTINUE
M1 = (M-1)/2
IF (M1.EQ.0) RETURN
DO 70 J = 1, M1
CALL RSWAP(M,A(1,J),1,A(M+1,J),1)
70 CONTINUE
M1 = (M+1)/2
M2 = M1 + M
CALL RSWAP(1,A(M1,1),1,A(M2,1),1)
CALL RSWAP(1,A(M1,M1),1,A(M2,M1),1)
M1 = N+1-(M-3)/2
IF(M1.GT.N) RETURN
DO 80 J = M1, N
CALL RSWAP(M,A(1,J),1,A(M+1,J),1)
80 CONTINUE
RETURN
C
C DOUBLE EVEN ORDER
C
100 K = 1
DO 120 I = 1, N
DO 110 J = 1, N
A(I,J) = K
IF (MOD(I,4)/2 .EQ. MOD(J,4)/2) A(I,J) = N*N+1 - K
K = K+1
110 CONTINUE
120 CONTINUE
RETURN
END
SUBROUTINE BASE(X,B,EPS,S,N)
DOUBLE PRECISION X,B,EPS,S(1),T
C
C STORE BASE B REPRESENTATION OF X IN S(1:N)
C
INTEGER PLUS,MINUS,DOT,ZERO,COMMA
DATA PLUS/41/,MINUS/42/,DOT/47/,ZERO/0/,COMMA/48/
L = 1
IF (X .GE. 0.0D0) S(L) = PLUS
IF (X .LT. 0.0D0) S(L) = MINUS
S(L+1) = ZERO
S(L+2) = DOT
X = DABS(X)
IF (X .NE. 0.0D0) K = DLOG(X)/DLOG(B)
IF (X .EQ. 0.0D0) K = 0
IF (X .GT. 1.0D0) K = K + 1
X = X/B**K
IF (B*X .GE. B) K = K + 1
IF (B*X .GE. B) X = X/B
IF (EPS .NE. 0.0D0) M = -DLOG(EPS)/DLOG(B) + 4
IF (EPS .EQ. 0.0D0) M = 54
DO 10 L = 4, M
X = B*X
J = IDINT(X)
S(L) = DFLOAT(J)
X = X - S(L)
10 CONTINUE
S(M+1) = COMMA
IF (K .GE. 0) S(M+2) = PLUS
IF (K .LT. 0) S(M+2) = MINUS
T = DABS(DFLOAT(K))
N = M + 3
IF (T .GE. B) N = N + IDINT(DLOG(T)/DLOG(B))
L = N
20 J = IDINT(DMOD(T,B))
S(L) = DFLOAT(J)
L = L - 1
T = T/B
IF (L .GE. M+3) GO TO 20
RETURN
END
DOUBLE PRECISION FUNCTION URAND(IY)
INTEGER IY
C
C URAND IS A UNIFORM RANDOM NUMBER GENERATOR BASED ON THEORY AND
C SUGGESTIONS GIVEN IN D.E. KNUTH (1969), VOL 2. THE INTEGER IY
C SHOULD BE INITIALIZED TO AN ARBITRARY INTEGER PRIOR TO THE FIRST CALL
C TO URAND. THE CALLING PROGRAM SHOULD NOT ALTER THE VALUE OF IY
C BETWEEN SUBSEQUENT CALLS TO URAND. VALUES OF URAND WILL BE RETURNED
C IN THE INTERVAL (0,1).
C
INTEGER IA,IC,ITWO,M2,M,MIC
DOUBLE PRECISION HALFM,S
DOUBLE PRECISION DATAN,DSQRT
DATA M2/0/,ITWO/2/
IF (M2 .NE. 0) GO TO 20
C
C IF FIRST ENTRY, COMPUTE MACHINE INTEGER WORD LENGTH
C
M = 1
10 M2 = M
M = ITWO*M2
IF (M .GT. M2) GO TO 10
HALFM = M2
C
C COMPUTE MULTIPLIER AND INCREMENT FOR LINEAR CONGRUENTIAL METHOD
C
IA = 8*IDINT(HALFM*DATAN(1.D0)/8.D0) + 5
IC = 2*IDINT(HALFM*(0.5D0-DSQRT(3.D0)/6.D0)) + 1
MIC = (M2 - IC) + M2
C
C S IS THE SCALE FACTOR FOR CONVERTING TO FLOATING POINT
C
S = 0.5D0/HALFM
C
C COMPUTE NEXT RANDOM NUMBER
C
20 IY = IY*IA
C
C THE FOLLOWING STATEMENT IS FOR COMPUTERS WHICH DO NOT ALLOW
C INTEGER OVERFLOW ON ADDITION
C
IF (IY .GT. MIC) IY = (IY - M2) - M2
C
IY = IY + IC
C
C THE FOLLOWING STATEMENT IS FOR COMPUTERS WHERE THE
C WORD LENGTH FOR ADDITION IS GREATER THAN FOR MULTIPLICATION
C
IF (IY/2 .GT. M2) IY = (IY - M2) - M2
C
C THE FOLLOWING STATEMENT IS FOR COMPUTERS WHERE INTEGER
C OVERFLOW AFFECTS THE SIGN BIT
C
IF (IY .LT. 0) IY = (IY + M2) + M2
URAND = DFLOAT(IY)*S
RETURN
END
SUBROUTINE WMUL(AR,AI,BR,BI,CR,CI)
DOUBLE PRECISION AR,AI,BR,BI,CR,CI,T,FLOP
C C = A*B
T = AR*BI + AI*BR
IF (T .NE. 0.0D0) T = FLOP(T)
CR = FLOP(AR*BR - AI*BI)
CI = T
RETURN
END
SUBROUTINE WDIV(AR,AI,BR,BI,CR,CI)
DOUBLE PRECISION AR,AI,BR,BI,CR,CI
C C = A/B
DOUBLE PRECISION S,D,ARS,AIS,BRS,BIS,FLOP
S = DABS(BR) + DABS(BI)
IF (S .EQ. 0.0D0) CALL ERROR(27)
IF (S .EQ. 0.0D0) RETURN
ARS = AR/S
AIS = AI/S
BRS = BR/S
BIS = BI/S
D = BRS**2 + BIS**2
CR = FLOP((ARS*BRS + AIS*BIS)/D)
CI = (AIS*BRS - ARS*BIS)/D
IF (CI .NE. 0.0D0) CI = FLOP(CI)
RETURN
END
SUBROUTINE WSIGN(XR,XI,YR,YI,ZR,ZI)
DOUBLE PRECISION XR,XI,YR,YI,ZR,ZI,PYTHAG,T
C IF Y .NE. 0, Z = X*Y/ABS(Y)
C IF Y .EQ. 0, Z = X
T = PYTHAG(YR,YI)
ZR = XR
ZI = XI
IF (T .NE. 0.0D0) CALL WMUL(YR/T,YI/T,ZR,ZI,ZR,ZI)
RETURN
END
SUBROUTINE WSQRT(XR,XI,YR,YI)
DOUBLE PRECISION XR,XI,YR,YI,S,TR,TI,PYTHAG,FLOP
C Y = SQRT(X) WITH YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
C
TR = XR
TI = XI
S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
IF (TR .GE. 0.0D0) YR = FLOP(S)
IF (TI .LT. 0.0D0) S = -S
IF (TR .LE. 0.0D0) YI = FLOP(S)
IF (TR .LT. 0.0D0) YR = FLOP(0.5D0*(TI/YI))
IF (TR .GT. 0.0D0) YI = FLOP(0.5D0*(TI/YR))
RETURN
END
SUBROUTINE WLOG(XR,XI,YR,YI)
DOUBLE PRECISION XR,XI,YR,YI,T,R,PYTHAG
C Y = LOG(X)
R = PYTHAG(XR,XI)
IF (R .EQ. 0.0D0) CALL ERROR(32)
IF (R .EQ. 0.0D0) RETURN
T = DATAN2(XI,XR)
IF (XI.EQ.0.0D0 .AND. XR.LT.0.0D0) T = DABS(T)
YR = DLOG(R)
YI = T
RETURN
END
SUBROUTINE WATAN(XR,XI,YR,YI)
C Y = ATAN(X) = (I/2)*LOG((I+X)/(I-X))
DOUBLE PRECISION XR,XI,YR,YI,TR,TI
IF (XI .NE. 0.0D0) GO TO 10
YR = DATAN2(XR,1.0D0)
YI = 0.0D0
RETURN
10 IF (XR.NE.0.0D0 .OR. DABS(XI).NE.1.0D0) GO TO 20
CALL ERROR(32)
RETURN
20 CALL WDIV(XR,1.0D0+XI,-XR,1.0D0-XI,TR,TI)
CALL WLOG(TR,TI,TR,TI)
YR = -TI/2.0D0
YI = TR/2.0D0
RETURN
END
DOUBLE PRECISION FUNCTION WNRM2(N,XR,XI,INCX)
DOUBLE PRECISION XR(1),XI(1),PYTHAG,S
C NORM2(X)
S = 0.0D0
IF (N .LE. 0) GO TO 20
IX = 1
DO 10 I = 1, N
S = PYTHAG(S,XR(IX))
S = PYTHAG(S,XI(IX))
IX = IX + INCX
10 CONTINUE
20 WNRM2 = S
RETURN
END
DOUBLE PRECISION FUNCTION WASUM(N,XR,XI,INCX)
DOUBLE PRECISION XR(1),XI(1),S,FLOP
C NORM1(X)
S = 0.0D0
IF (N .LE. 0) GO TO 20
IX = 1
DO 10 I = 1, N
S = FLOP(S + DABS(XR(IX)) + DABS(XI(IX)))
IX = IX + INCX
10 CONTINUE
20 WASUM = S
RETURN
END
INTEGER FUNCTION IWAMAX(N,XR,XI,INCX)
DOUBLE PRECISION XR(1),XI(1),S,P
C INDEX OF NORMINF(X)
K = 0
IF (N .LE. 0) GO TO 20
K = 1
S = 0.0D0
IX = 1
DO 10 I = 1, N
P = DABS(XR(IX)) + DABS(XI(IX))
IF (P .GT. S) K = I
IF (P .GT. S) S = P
IX = IX + INCX
10 CONTINUE
20 IWAMAX = K
RETURN
END
SUBROUTINE WRSCAL(N,S,XR,XI,INCX)
DOUBLE PRECISION S,XR(1),XI(1),FLOP
IF (N .LE. 0) RETURN
IX = 1
DO 10 I = 1, N
XR(IX) = FLOP(S*XR(IX))
IF (XI(IX) .NE. 0.0D0) XI(IX) = FLOP(S*XI(IX))
IX = IX + INCX
10 CONTINUE
RETURN
END
SUBROUTINE WSCAL(N,SR,SI,XR,XI,INCX)
DOUBLE PRECISION SR,SI,XR(1),XI(1)
IF (N .LE. 0) RETURN
IX = 1
DO 10 I = 1, N
CALL WMUL(SR,SI,XR(IX),XI(IX),XR(IX),XI(IX))
IX = IX + INCX
10 CONTINUE
RETURN
END
SUBROUTINE WAXPY(N,SR,SI,XR,XI,INCX,YR,YI,INCY)
DOUBLE PRECISION SR,SI,XR(1),XI(1),YR(1),YI(1),FLOP
IF (N .LE. 0) RETURN
IF (SR .EQ. 0.0D0 .AND. SI .EQ. 0.0D0) RETURN
IX = 1
IY = 1
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
DO 10 I = 1, N
YR(IY) = FLOP(YR(IY) + SR*XR(IX) - SI*XI(IX))
YI(IY) = YI(IY) + SR*XI(IX) + SI*XR(IX)
IF (YI(IY) .NE. 0.0D0) YI(IY) = FLOP(YI(IY))
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
END
DOUBLE PRECISION FUNCTION WDOTUR(N,XR,XI,INCX,YR,YI,INCY)
DOUBLE PRECISION XR(1),XI(1),YR(1),YI(1),S,FLOP
S = 0.0D0
IF (N .LE. 0) GO TO 20
IX = 1
IY = 1
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
DO 10 I = 1, N
S = FLOP(S + XR(IX)*YR(IY) - XI(IX)*YI(IY))
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
20 WDOTUR = S
RETURN
END
DOUBLE PRECISION FUNCTION WDOTUI(N,XR,XI,INCX,YR,YI,INCY)
DOUBLE PRECISION XR(1),XI(1),YR(1),YI(1),S,FLOP
S = 0.0D0
IF (N .LE. 0) GO TO 20
IX = 1
IY = 1
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
DO 10 I = 1, N
S = S + XR(IX)*YI(IY) + XI(IX)*YR(IY)
IF (S .NE. 0.0D0) S = FLOP(S)
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
20 WDOTUI = S
RETURN
END
DOUBLE PRECISION FUNCTION WDOTCR(N,XR,XI,INCX,YR,YI,INCY)
DOUBLE PRECISION XR(1),XI(1),YR(1),YI(1),S,FLOP
S = 0.0D0
IF (N .LE. 0) GO TO 20
IX = 1
IY = 1
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
DO 10 I = 1, N
S = FLOP(S + XR(IX)*YR(IY) + XI(IX)*YI(IY))
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
20 WDOTCR = S
RETURN
END
DOUBLE PRECISION FUNCTION WDOTCI(N,XR,XI,INCX,YR,YI,INCY)
DOUBLE PRECISION XR(1),XI(1),YR(1),YI(1),S,FLOP
S = 0.0D0
IF (N .LE. 0) GO TO 20
IX = 1
IY = 1
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
DO 10 I = 1, N
S = S + XR(IX)*YI(IY) - XI(IX)*YR(IY)
IF (S .NE. 0.0D0) S = FLOP(S)
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
20 WDOTCI = S
RETURN
END
SUBROUTINE WCOPY(N,XR,XI,INCX,YR,YI,INCY)
DOUBLE PRECISION XR(1),XI(1),YR(1),YI(1)
IF (N .LE. 0) RETURN
IX = 1
IY = 1
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
DO 10 I = 1, N
YR(IY) = XR(IX)
YI(IY) = XI(IX)
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
END
SUBROUTINE WSET(N,XR,XI,YR,YI,INCY)
INTEGER N,INCY
DOUBLE PRECISION XR,XI,YR(1),YI(1)
IY = 1
IF (N .LE. 0 ) RETURN
DO 10 I = 1,N
YR(IY) = XR
YI(IY) = XI
IY = IY + INCY
10 CONTINUE
RETURN
END
SUBROUTINE WSWAP(N,XR,XI,INCX,YR,YI,INCY)
DOUBLE PRECISION XR(1),XI(1),YR(1),YI(1),T
IF (N .LE. 0) RETURN
IX = 1
IY = 1
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
DO 10 I = 1, N
T = XR(IX)
XR(IX) = YR(IY)
YR(IY) = T
T = XI(IX)
XI(IX) = YI(IY)
YI(IY) = T
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
END
SUBROUTINE RSET(N,DX,DY,INCY)
C
C COPIES A SCALAR, X, TO A SCALAR, Y.
DOUBLE PRECISION DX,DY(1)
C
IF (N.LE.0) RETURN
IY = 1
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
DO 10 I = 1,N
DY(IY) = DX
IY = IY + INCY
10 CONTINUE
RETURN
END
SUBROUTINE RSWAP(N,X,INCX,Y,INCY)
DOUBLE PRECISION X(1),Y(1),T
IF (N .LE. 0) RETURN
IX = 1
IY = 1
IF (INCX.LT.0) IX = (-N+1)*INCX+1
IF (INCY.LT.0) IY = (-N+1)*INCY+1
DO 10 I = 1, N
T = X(IX)
X(IX) = Y(IY)
Y(IY) = T
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
END
SUBROUTINE RROT(N,DX,INCX,DY,INCY,C,S)
C
C APPLIES A PLANE ROTATION.
DOUBLE PRECISION DX(1),DY(1),DTEMP,C,S,FLOP
INTEGER I,INCX,INCY,IX,IY,N
C
IF (N.LE.0) RETURN
IX = 1
IY = 1
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
DO 10 I = 1,N
DTEMP = FLOP(C*DX(IX) + S*DY(IY))
DY(IY) = FLOP(C*DY(IY) - S*DX(IX))
DX(IX) = DTEMP
IX = IX + INCX
IY = IY + INCY
10 CONTINUE
RETURN
END
SUBROUTINE RROTG(DA,DB,C,S)
C
C CONSTRUCT GIVENS PLANE ROTATION.
C
DOUBLE PRECISION DA,DB,C,S,RHO,PYTHAG,FLOP,R,Z
C
RHO = DB
IF ( DABS(DA) .GT. DABS(DB) ) RHO = DA
C = 1.0D0
S = 0.0D0
Z = 1.0D0
R = FLOP(DSIGN(PYTHAG(DA,DB),RHO))
IF (R .NE. 0.0D0) C = FLOP(DA/R)
IF (R .NE. 0.0D0) S = FLOP(DB/R)
IF ( DABS(DA) .GT. DABS(DB) ) Z = S
IF ( DABS(DB) .GE. DABS(DA) .AND. C .NE. 0.0D0 ) Z = FLOP(1.0D0/C)
DA = R
DB = Z
RETURN
END
LOGICAL FUNCTION EQID(X,Y)
C CHECK FOR EQUALITY OF TWO NAMES
INTEGER X(4),Y(4)
EQID = .TRUE.
DO 10 I = 1, 4
10 EQID = EQID .AND. (X(I).EQ.Y(I))
RETURN
END
SUBROUTINE PUTID(X,Y)
C STORE A NAME
INTEGER X(4),Y(4)
DO 10 I = 1, 4
10 X(I) = Y(I)
RETURN
END
DOUBLE PRECISION FUNCTION ROUND(X)
DOUBLE PRECISION X,Y,Z,E,H
DATA H/1.0D9/
Z = DABS(X)
Y = Z + 1.0D0
IF (Y .EQ. Z) GO TO 40
Y = 0.0D0
E = H
10 IF (E .GE. Z) GO TO 20
E = 2.0D0*E
GO TO 10
20 IF (E .LE. H) GO TO 30
IF (E .LE. Z) Y = Y + E
IF (E .LE. Z) Z = Z - E
E = E/2.0D0
GO TO 20
30 Z = IDINT(Z + 0.5D0)
Y = Y + Z
IF (X .LT. 0.0D0) Y = -Y
ROUND = Y
RETURN
40 ROUND = X
RETURN
END
FUNCTION DFLOAT(I)
C
C THIS IS THE AMIGA FUNCTION WHICH CONVERTS INTEGERS TO DOUBLE FLOATS
C
IMPLICIT NONE
DFLOAT = DBLE(I)
RETURN
END