Frozen Fish 1: Amiga

home *** CD-ROM | disk | FTP | other *** search

/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d2xx / d267 / matlab.lha / Matlab / matlab.zoo / matlab / src / matlab.for next >

Wrap

Text File | 1989-06-20 | 220.2 KB | 7,603 lines

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