SUBROUTINE SMESSG(NUNIT,IP,NMESS) C DEFINE THE TEXT OF ERROR MESSAGES. C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS. C REVISED 860623 C REVISED YYMMDD C AUTH=R. J. HANSON, SANDIA NATIONAL LABS. LOGICAL EX,OP,INQ INTEGER NUNIT(3) CHARACTER *256 MESS(09) CHARACTER *256 M DATA MESS(01)/ .' THE COMPILER IS GENERATING BAD CODE FOR IN-LINE DOT PRODUCTS OR .IS INCORRECTLY EVALUATING THE ARITHMETIC EXPRESSIONS J*((J+1)*J)/2 . - (J+1)*J*(J-1)/3, J=1 THRU 32.'/ DATA MESS(02)/ .' ABNORMAL OR EARLY END-OF-FILE WHILE READING NAME OF FILE THAT CO .NTAINS THE NAMES OF THE SUBPROGRAMS AND THE SUMMARY FILES.'/ DATA MESS(03)/ .' THE ABOVE FILE NAME MUST BE PRESENT ON THE SYSTEM. IT IS NOT. .THIS FILE CONTAINS THE NAMES OF THE SUBPROGRAMS AND THE SUMMARY FI .LES.'/ DATA MESS(04)/ .' ABNORMAL OR EARLY END-OF-FILE WHILE READING NAMES OF SUBPROGRAMS . FROM THE ABOVE FILE NAME.'/ DATA MESS(05)/ .' ABNORNAL OR EARLY END-OF-FILE WHILE READING NAMES OF FILES FOR S .UMMARY OUTPUT.'/ DATA MESS(06)/ .' ENTER NAME AND UNIT NUMBER OF FILE CONTAINING NAMES OF SUBPROGRA .MS AND SUMMARY FILES. ONE ITEM PER LINE, PLEASE.'/ DATA MESS(07)/ .' THE SNAP-SHOT FILE OF ACTIVE TESTS CANNOT BE OPENED WITH ''NEW'' . STATUS OR IT CANNOT BE DELETED. THIS FILE SHOULD NOT BE PRESENT .ON THE SYSTEM.'/ DATA MESS(08)/ .' THE SUMMARY FILE OF ACTIVE TESTS CANNOT BE OPENED WITH ''UNKOWN' .' STATUS. THIS FILE SHOULD NOT BE PRESENT ON THE SYSTEM.'/ M = MESS(NMESS) NL = 256 NS = 72 INQ = .TRUE. DO 10 I = NL,1,-1 IF (ICHAR(M(I:I)).NE.ICHAR(' ')) GO TO 20 10 CONTINUE NL = 0 GO TO 30 * 20 NL = I C FOUND NS = POINTER TO LAST NONBLANK IN MESSAGE. 30 CONTINUE C NOW OUTPUT THE MESSAGE. PARSE IT SO THAT UP TO NS CHARS. PER LINE C PRINT, BUT DO NOT BREAK WORDS ACCROSS LINES. IS = 1 40 CONTINUE IE = MIN(NL,IS+NS) IF (IS.GE.IE) GO TO 70 50 CONTINUE IF (ICHAR(M(IE:IE)).EQ.ICHAR(' ') .OR. NL-IS.LT.NS) GO TO 60 IE = IE - 1 IF (IE.GT.IS) GO TO 50 60 CONTINUE IF (INQ) THEN INQUIRE (UNIT=NUNIT(IP),EXIST=EX,OPENED=OP) END IF C IF THE INTENDED UNIT IS NOT OPENED, SEND OUTPUT TO C STANDARD OUTPUT SO IT WILL BE SEEN. IF ( .NOT. OP .OR. .NOT. EX .OR. NUNIT(IP).EQ.0) THEN IF (IE.EQ.NL) THEN WRITE (*,'(A,/)') M(IS:IE) * ELSE WRITE (*,'(A)') M(IS:IE) END IF * INQ = .FALSE. * ELSE LUNIT = NUNIT(IP) WRITE (LUNIT,'(A)') M(IS:IE) END IF * IS = IE GO TO 40 * 70 CONTINUE RETURN END * SUBROUTINE SCHCK1(ISNUM,SNAME,IG,DOPE,NUNIT,AVIGR,FATAL) C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS. C REVISED 860623 C REVISED YYMMDD C AUTH=R. J. HANSON, SANDIA NATIONAL LABS. C THIS PROGRAM HAS TWO PARTS. THE FIRST PART CHECKS TO SEE C IF ANY DATA GETS CHANGED WHEN NONE SHOULD. FOR EXAMPLE WHEN C USING AN INVALID OPTION OR NONPOSITVE PROBLEM DIMENSIONS. C THE SECOND PART CHECKS THAT THE RESULTS ARE REASONABLY ACCURATE. C DIMENSION AND PROBLEM SIZE DATA.. INTEGER INC(04),IDIM(08),NUNIT(2) REAL ALF(04),BET(04),SDIFF LOGICAL ISAME(13),LSE,FATAL,SAME,NCHNG,RESET CHARACTER *128 DOPE(2) CHARACTER *6 SNAME CHARACTER *3 ICH CHARACTER *1 ICHS,ICI INTEGER LA,LV PARAMETER (LA=4096,LV=4096,LMN=2048) REAL A(LA),AS(LA),X(LV),XS(LV) REAL Y(LV),YS(LV),YT(LMN),XT(LMN) REAL ALPHA,ALS,BETA,BLS,T,TRANSL,XN PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0) COMMON /ARRAYS/AR,AS,X,XS,Y,YS,YT,XT EXTERNAL SDIFF * DATA ALF/-1.E0,2.E0,.3E0,1.E0/ DATA BET/-1.E0,0.E0,.3E0,1.E0/ DATA INC/-2,-1,1,2/ DATA IDIM/1,2,4,8,64,128,2048,0/ DATA ICH/'NT/'/ FATAL = .FALSE. C CHECK GENERAL MATRIX-VECTOR PRODUCT, Y = ALPHA*A*X+BETA*Y, NO.1-2. IF (ISNUM.LT.0) GO TO 220 NC = 0 RESET = .TRUE. AVIGR = ZERO IX = 0 10 IX = IX + 1 IF (IX.GT.4) GO TO 200 INCX = INC(IX) ALPHA = ALF(IX) IY = 0 20 IY = IY + 1 IF (IY.GT.4) GO TO 190 INCY = INC(IY) BETA = BET(IY) MM = 0 30 MM = MM + 1 IF (MM.GT.8) GO TO 180 M = IDIM(MM) NN = 0 40 NN = NN + 1 IF (NN.GT.8) GO TO 170 N = IDIM(NN) IC = 0 50 IC = IC + 1 IF (IC.GT.3) GO TO 160 IF (FATAL) GO TO 210 C SET DEFAULT BANDWIDTH SO PRINTING WILL BE OK. KL = MAX(0,M-1) KU = MAX(0,N-1) C DEFINE THE NUMBER OF ARGUMENTS AND THE Y ARGUMENT NUMBER. IF (ISNUM.EQ.1) THEN LDA = MAX(M,1) NARGS = 11 IYARG = 10 * ELSE IF (ISNUM.EQ.2) THEN NARGS = 13 IYARG = 12 C DEFINE BANDWIDTH OF MATRIX FOR TEST OF SGBMV. KL = MAX(0,MIN(M-1,M/2)) KU = MAX(0,MIN(N-1,N/2)) LDA = MAX(KL+KU+1,M) END IF * ICI = ICH(IC:IC) IF (ICHAR(ICI).EQ.ICHAR('T')) THEN ML = N NL = M INCCA = 1 INCRA = LDA * ELSE ML = M NL = N INCCA = LDA INCRA = 1 END IF * C IF NOT ENOUGH STORAGE, SKIP THIS CASE. (AVOID EXPLICT LDA*N). IF (SQRT(REAL(N))*SQRT(REAL(LDA)).GT.SQRT(REAL(LA))) GO TO 50 C DO (PREPARE NOTES FOR THIS TEST) C C PRINT A MESSAGE THAT GIVES DEBUGGING INFORMATION. THIS C MESSAGE SAYS.. C IN SUBPROGRAM XXXXX TESTS WERE ACTIVE WITH C OPTION = 'A' C M = IIII, N = IIII, C INCX = IIII, INCY = IIII, C KL = IIII, KU = IIII. C THE MAIN IDEA HERE IS THAT A SERIOUS BUG THAT OCCURS DURING THE C TESTING OF THESE SUBPROGRAMS MAY LOSE PROGRAM CONTROL. THIS C AUXILLIARY FILE CONTAINS THE DIMENSIONS THAT RESULTED IN THE LOSS C OF CONTROL. HENCE IT PROVIDES THE IMPLEMENTOR WITH MORE COMPLETE C INFORMATION ABOUT WHERE TO START TRACKING DOWN THE BUG. IF (NUNIT(1).GT.0) THEN C IF UNIT IS NOT AVAILABLE WITH 'NEW' STATUS, OPEN WITH C 'OLD' AND THEN DELETE IT. ISTAT = 1 CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR) IF (IERROR.EQ.1) GO TO 60 C GET RID OF ANY OLD FILE. CLOSE (UNIT=NUNIT(1),STATUS='DELETE',ERR=60) 60 CONTINUE ISTAT = 2 C CREATE A NEW FILE FOR THE NEXT TEST. CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR) IF (IERROR.EQ.0) GO TO 80 NMESS = 7 C DO (PRINT A MESSAGE) C PRINT AN ERROR MESSAGE ABOUT OPENING THE NAME FILE. CALL SMESSG(0,1,NMESS) FATAL = .TRUE. GO TO 210 * 80 CONTINUE WRITE (NUNIT(1),9001) SNAME,ICI,M,N,INCX,INCY,KL,KU C CLOSE THE FILE SO USEFUL STATUS INFORMATION IS SEALED. CLOSE (UNIT=NUNIT(1)) END IF C DO (DEFINE A SET OF PROBLEM DATA) ASSIGN 90 TO IGO3 GO TO 340 * 90 CONTINUE C DO (CALL SUBROUTINE) ASSIGN 100 TO IGO1 GO TO 280 * 100 CONTINUE IF (M.LE.0 .OR. N.LE.0 .OR. ICHAR(ICI).EQ.ICHAR('/')) THEN C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES) ASSIGN 110 TO IGO2 GO TO 240 * 110 CONTINUE C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN. SAME = .TRUE. DO 120 I = 1,NARGS SAME = SAME .AND. ISAME(I) IF ( .NOT. ISAME(I)) THEN WRITE (NUNIT(2),9011) SNAME,I,ICI,M,N,INCX,INCY,KL,KU END IF * 120 CONTINUE IF ( .NOT. SAME) THEN FATAL = .TRUE. GO TO 210 * END IF * ELSE C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES) ASSIGN 130 TO IGO2 GO TO 240 * 130 CONTINUE C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN. SAME = .TRUE. DO 140 I = 1,NARGS NCHNG = (I.EQ.IYARG .OR. ISAME(I)) SAME = SAME .AND. NCHNG IF ( .NOT. NCHNG) THEN WRITE (NUNIT(2),9021) SNAME,I,ICI,M,N,INCX,INCY,KL,KU END IF * 140 CONTINUE IF ( .NOT. SAME) THEN FATAL = .TRUE. GO TO 210 * END IF * NC = NC + 1 C DO (COMPUTE A CORRECT RESULT) ASSIGN 150 TO IGO4 GO TO 370 * 150 CONTINUE C IF GOT REALLY BAD ANSWER, PRINT NOTE AND GO BACK. IF (FATAL) GO TO 200 * END IF * GO TO 50 * 160 CONTINUE GO TO 40 * 170 CONTINUE GO TO 30 * 180 CONTINUE GO TO 20 * 190 CONTINUE GO TO 10 * 200 CONTINUE C REPORT ON ACCURACY OF DATA. WRITE (NUNIT(2),9031) ISNUM,SNAME,AVIGR,IG GO TO 230 * 210 CONTINUE WRITE (NUNIT(2),9041) ISNUM,SNAME GO TO 230 * 220 CONTINUE WRITE (NUNIT(2),9051) - ISNUM,SNAME 230 CONTINUE RETURN * 240 CONTINUE C PROCEDURE (SEE WHAT DATA CHANGED INSIDE SUBROUTINES) IF (ISNUM.EQ.1) THEN ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS) ISAME(2) = MS .EQ. M ISAME(3) = NS .EQ. N ISAME(4) = ALS .EQ. ALPHA ISAME(5) = .TRUE. IF (M.GT.0 .AND. N.GT.0) ISAME(5) = LSE(AS,A,M,N,LDA) ISAME(6) = LDAS .EQ. LDA ISAME(7) = .TRUE. IF (NL.GT.0 .AND. INCX.NE.0) ISAME(7) = LSE(XS,X,1,NL, . ABS(INCX)) ISAME(8) = INCXS .EQ. INCX ISAME(9) = BLS .EQ. BETA ISAME(10) = .TRUE. IF (ML.GT.0 .AND. INCY.NE.0) ISAME(10) = LSE(YS,Y,1,ML, . ABS(INCY)) ISAME(11) = INCYS .EQ. INCY * ELSE IF (ISNUM.EQ.2) THEN C COMPARE THE MATRIX IN THE SGBMV DATA STRUCTURE WITH C THE SAVED COPY. ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS) ISAME(2) = MS .EQ. M ISAME(3) = NS .EQ. N ISAME(4) = KLS .EQ. KL ISAME(5) = KUS .EQ. KU ISAME(6) = ALS .EQ. ALPHA ISAME(7) = .TRUE. IF (N.GT.0 .AND. M.GT.0) THEN DO 260 J = 1,N DO 250 I = MAX(1,J-KU),MIN(M,J+KL) IF (AS(1+ (I-1)+ (J-1)*LDA).NE. . A(1+ (KU+I-J)+ (J-1)*LDA)) THEN ISAME(7) = .FALSE. GO TO 270 * END IF * 250 CONTINUE 260 CONTINUE 270 CONTINUE END IF * ISAME(8) = LDAS .EQ. LDA ISAME(9) = .TRUE. IF (NL.GT.0 .AND. INCX.NE.0) ISAME(9) = LSE(XS,X,1,NL, . ABS(INCX)) ISAME(10) = INCXS .EQ. INCX ISAME(11) = BLS .EQ. BETA ISAME(12) = .TRUE. IF (ML.GT.0 .AND. INCY.NE.0) ISAME(12) = LSE(YS,Y,1,ML, . ABS(INCY)) ISAME(13) = INCYS .EQ. INCY END IF * GO TO IGO2 * 280 CONTINUE C PROCEDURE (CALL SUBROUTINE) C SAVE EVERY DATUM BEFORE THE CALL. ICHS = ICI MS = M NS = N KLS = KL KUS = KU ALS = ALPHA DO 290 I = 1,LDA*N AS(I) = A(I) 290 CONTINUE LDAS = LDA C SAVE COPY OF THE X AND Y VECTORS. IBX = 1 IF (INCX.LT.0) IBX = 1 + (1-NL)*INCX DO 300 J = 1,NL XS(IBX+ (J-1)*INCX) = X(IBX+ (J-1)*INCX) 300 CONTINUE INCXS = INCX BLS = BETA IBY = 1 IF (INCY.LT.0) IBY = 1 + (1-ML)*INCY DO 310 I = 1,ML YS(IBY+ (I-1)*INCY) = Y(IBY+ (I-1)*INCY) 310 CONTINUE INCYS = INCY IF (ISNUM.EQ.1) THEN CALL SGEMV(ICI,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * ELSE IF (ISNUM.EQ.2) THEN C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH SGBMV. DO 330 J = 1,N DO 320 I = MAX(1,J-KU),MIN(M,J+KL) A(1+ (KU+I-J)+ (J-1)*LDA) = AS(1+ (I-1)+ (J-1)*LDA) 320 CONTINUE 330 CONTINUE CALL SGBMV(ICI,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) END IF * GO TO IGO1 * 340 CONTINUE C PROCEDURE (DEFINE A SET OF PROBLEM DATA) C DO NOTHING IF BOTH DIMENSIONS ARE NOT POSITIVE. IF (M.LE.0 .OR. N.LE.0) GO TO IGO3 TRANSL = ZERO CALL SMAKE(A,M,N,LDA,RESET,TRANSL) C TRIM AWAY ELEMENTS OUTSIDE THE BANDWIDTH FOR SGBMV. IF (ISNUM.EQ.2) THEN DO 360 J = 1,N DO 350 I = 1,M T = A(1+ (I-1)+ (J-1)*LDA) IF (J.GT.I .AND. J-I.GT.KU) T = ZERO IF (I.GT.J .AND. I-J.GT.KL) T = ZERO A(1+ (I-1)+ (J-1)*LDA) = T 350 CONTINUE 360 CONTINUE END IF * TRANSL = 500.E0 RESET = .FALSE. CALL SMAKE(X,1,NL,MAX(1,ABS(INCX)),RESET,TRANSL) IF (NL.GT.1 .AND. INCX.EQ.1) X(NL/2) = ZERO TRANSL = ZERO CALL SMAKE(Y,1,ML,MAX(1,ABS(INCY)),RESET,TRANSL) GO TO IGO3 * 370 CONTINUE C PROCEDURE (COMPUTE A CORRECT RESULT) C COMPUTE THE CONDITION NUMBER TO USE AS GAUGE FOR ACCURATE RESULTS. C THIS IS RETURNED IN XT(*). C COMPUTE THE APPROXIMATE CORRECT RESULT. C THIS IS RETURNED IN YT(*). IF (INCY.LT.0) THEN IBY = (1-ML)*INCY + 1 * ELSE IBY = 1 END IF * DO 390 I = 1,ML YT(I) = BETA*YS(IBY+ (I-1)*INCY) XT(I) = YS(IBY+ (I-1)*INCY)**2 IF (INCX.LT.0) THEN IBX = (1-NL)*INCX + 1 * ELSE IBX = 1 END IF * DO 380 J = 1,NL YT(I) = YT(I) + AS(1+ (I-1)*INCRA+ (J-1)*INCCA)*ALPHA* . XS(IBX+ (J-1)*INCX) XT(I) = XT(I) + AS(1+ (I-1)*INCRA+ (J-1)*INCCA)**2 380 CONTINUE XT(I) = SQRT(XT(I)) 390 CONTINUE XN = BETA**2 DO 400 J = 1,NL XN = XN + XS(IBX+ (J-1)*INCX)**2 400 CONTINUE XN = SQRT(XN) C COMPUTE THE GAUGES FOR THE RESULTS. DO 410 I = 1,ML XT(I) = XT(I)*XN 410 CONTINUE C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS. DO 420 I = 1,ML YT(I) = YT(I) - Y(IBY+ (I-1)*INCY) 420 CONTINUE C COMPUTE THE GRADE OF THIS RESULT. IGR = 0 T = ONE 430 CONTINUE C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING. IF (IGR.GE.IG) GO TO 460 DO 440 I = 1,ML IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 440 T = T*HALF IGR = IGR + 1 GO TO 430 * 440 CONTINUE C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE C PROBLEMS. 450 CONTINUE AVIGR = MAX(AVIGR,REAL(IGR)) GO TO IGO4 * 460 CONTINUE FATAL = .TRUE. GO TO 450 * * LAST EXECUTABLE LINE OF SCHCK1 9001 FORMAT (' IN SUBPROGRAM ',A,/,' TESTS ACTIVE WITH OPTION = ',A,/, . ' M =',I4,', N = ',I4,/,' INCX = ',I2,', INCY = ',I2,/,' KL =', . I4,', KU =',I4) 9011 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2, . ' WAS CHANGED WITH INVALID INPUT.',/,' OPTION = ',A,', M =',I4, . ', N = ',I4,/,' INCX = ',I2,', INCY = ',I2,/,' KL =',I4, . ', KU =',I4) 9021 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2, . ' WAS CHANGED WHILE COMPUTING',/,' OPTION = ',A,', M =',I4, . ', N = ',I4,/,' INCX = ',I2,', INCY = ',I2,/,' KL =',I4, . ', KU =',I4) 9031 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'RECEIVED A LOSS GRADE OF ', . F5.2,' OUT OF ',I3) 9041 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'FAILED.') 9051 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'NOT TESTED.') END SUBROUTINE SCHCK2(ISNUM,SNAME,IG,DOPE,NUNIT,AVIGR,FATAL) C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS. C TEST SSYMV, 03, SSBMV, 04, AND SSPMV, 05. C REVISED 860623 C REVISED YYMMDD C AUTH=R. J. HANSON, SANDIA NATIONAL LABS. C THIS PROGRAM HAS TWO PARTS. THE FIRST PART CHECKS TO SEE C IF ANY DATA GETS CHANGED WHEN NONE SHOULD. FOR EXAMPLE WHEN C USING AN INVALID OPTION OR NONPOSITVE PROBLEM DIMENSIONS. C THE SECOND PART CHECKS THAT THE RESULTS ARE REASONABLY ACCURATE. C DIMENSION AND PROBLEM SIZE DATA.. INTEGER INC(04),IDIM(06),NUNIT(2) REAL ALF(04),BET(04) LOGICAL ISAME(13),LSE,FATAL,SAME,NCHNG,RESET CHARACTER *128 DOPE(2) CHARACTER *6 SNAME CHARACTER *3 ICH CHARACTER *1 ICHS,ICI INTEGER LA,LV PARAMETER (LA=4096,LV=4096,LMN=2048) REAL ALPHA,ALS,BETA,BLS,T,TRANSL,XN REAL A(LA),AS(LA),X(LV),XS(LV) REAL Y(LV),YS(LV),YT(LMN),XT(LMN) PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0) COMMON /ARRAYS/AR,AS,X,XS,Y,YS,YT,XT EXTERNAL SDIFF * DATA ALF/-1.E0,2.E0,.3E0,1.E0/ DATA BET/-1.E0,0.E0,.3E0,1.E0/ DATA INC/-2,-1,1,2/ DATA IDIM/1,2,4,8,64,0/ DATA ICH/'LU/'/ FATAL = .FALSE. C CHECK SYMMETRIC MATRIX-VECTOR PRODUCT, Y = ALPHA*A*X+BETA*Y, 3-5. IF (ISNUM.LT.0) GO TO 200 NC = 0 RESET = .TRUE. AVIGR = ZERO IX = 0 10 IX = IX + 1 IF (IX.GT.4) GO TO 180 INCX = INC(IX) ALPHA = ALF(IX) IY = 0 20 IY = IY + 1 IF (IY.GT.4) GO TO 170 INCY = INC(IY) BETA = BET(IY) NN = 0 30 NN = NN + 1 IF (NN.GT.6) GO TO 160 N = IDIM(NN) IC = 0 40 IC = IC + 1 IF (IC.GT.3) GO TO 150 IF (FATAL) GO TO 190 ICI = ICH(IC:IC) C DEFINE DEFAULT VALUE OF K SO PRINTING IS OK. K = MAX(0,N-1) C DEFINE THE NUMBER OF ARGUMENTS AND THE Y ARGUMENT NUMBER. LDA = MAX(N,1) IF (ISNUM.EQ.3) THEN NARGS = 10 IYARG = 09 * ELSE IF (ISNUM.EQ.4) THEN NARGS = 11 IYARG = 10 C DEFINE BANDWIDTH OF MATRIX FOR TEST OF SSBMV. K = INT(SQRT(REAL(N))+HALF) - 1 * ELSE IF (ISNUM.EQ.5) THEN NARGS = 9 IYARG = 8 END IF C DO (PREPARE NOTES FOR THIS TEST) C C PRINT A MESSAGE THAT GIVES DEBUGGING INFORMATION. THIS C MESSAGE SAYS.. C IN SUBPROGRAM XXXXX TESTS WERE ACTIVE WITH C OPTION = 'A' C N = IIII, C INCX = IIII, INCY = IIII, C K = IIII. C THE MAIN IDEA HERE IS THAT A SERIOUS BUG THAT OCCURS DURING THE C TESTING OF THESE SUBPROGRAMS MAY LOSE PROGRAM CONTROL. THIS C AUXILLIARY FILE CONTAINS THE DIMENSIONS THAT RESULTED IN THE LOSS C OF CONTROL. HENCE IT PROVIDES THE IMPLEMENTOR WITH MORE COMPLETE C INFORMATION ABOUT WHERE TO START TRACKING DOWN THE BUG. IF (NUNIT(1).GT.0) THEN C IF UNIT IS NOT AVAILABLE WITH 'NEW' STATUS, OPEN WITH C 'OLD' AND THEN DELETE IT. ISTAT = 1 CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR) IF (IERROR.EQ.1) GO TO 50 C GET RID OF ANY OLD FILE. CLOSE (UNIT=NUNIT(1),STATUS='DELETE',ERR=50) 50 CONTINUE ISTAT = 2 C CREATE A NEW FILE FOR THE NEXT TEST. CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR) IF (IERROR.EQ.0) GO TO 70 60 CONTINUE NMESS = 7 C DO (PRINT A MESSAGE) C PRINT AN ERROR MESSAGE ABOUT OPENING THE NAME FILE. CALL SMESSG(0,1,NMESS) FATAL = .TRUE. GO TO 190 * 70 CONTINUE WRITE (NUNIT(1),9001) SNAME,ICI,N,INCX,INCY,K C CLOSE THE FILE SO USEFUL STATUS INFORMATION IS SEALED. CLOSE (UNIT=NUNIT(1)) END IF C DO (DEFINE A SET OF PROBLEM DATA) ASSIGN 80 TO IGO3 GO TO 370 * 80 CONTINUE C DO (CALL SUBROUTINE) ASSIGN 90 TO IGO1 GO TO 290 * 90 CONTINUE IF (N.LE.0 .OR. ICHAR(ICI).EQ.ICHAR('/')) THEN C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES) ASSIGN 100 TO IGO2 GO TO 220 * 100 CONTINUE C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN. SAME = .TRUE. DO 110 I = 1,NARGS SAME = SAME .AND. ISAME(I) IF ( .NOT. ISAME(I)) THEN WRITE (NUNIT(2),9011) SNAME,I,ICI,N,INCX,INCY,K END IF * 110 CONTINUE IF ( .NOT. SAME) THEN FATAL = .TRUE. GO TO 190 * END IF * ELSE C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES) ASSIGN 120 TO IGO2 GO TO 220 * 120 CONTINUE C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN. SAME = .TRUE. DO 130 I = 1,NARGS NCHNG = (I.EQ.IYARG .OR. ISAME(I)) SAME = SAME .AND. NCHNG IF ( .NOT. NCHNG) THEN WRITE (NUNIT(2),9021) SNAME,I,ICI,N,INCX,INCY,K END IF * 130 CONTINUE IF ( .NOT. SAME) THEN FATAL = .TRUE. GO TO 190 * END IF * NC = NC + 1 C DO (COMPUTE A CORRECT RESULT) ASSIGN 140 TO IGO4 GO TO 420 * 140 CONTINUE C IF GOT REALLY BAD ANSWER, PRINT NOTE AND GO BACK. IF (FATAL) GO TO 180 * END IF * GO TO 40 * 150 CONTINUE GO TO 30 * 160 CONTINUE GO TO 20 * 170 CONTINUE GO TO 10 * 180 CONTINUE C REPORT ON ACCURACY OF DATA. WRITE (NUNIT(2),9031) ISNUM,SNAME,AVIGR,IG GO TO 210 * 190 CONTINUE WRITE (NUNIT(2),9041) ISNUM,SNAME GO TO 210 * 200 CONTINUE WRITE (NUNIT(2),9051) - ISNUM,SNAME 210 CONTINUE RETURN * 220 CONTINUE C PROCEDURE (SEE WHAT DATA CHANGED INSIDE SUBROUTINES) IF (ISNUM.EQ.3) THEN ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS) ISAME(2) = NS .EQ. N ISAME(3) = ALS .EQ. ALPHA ISAME(4) = .TRUE. IF (N.GT.0) ISAME(4) = LSE(AS,A,N,N,LDA) ISAME(5) = LDAS .EQ. LDA ISAME(6) = .TRUE. IF (N.GT.0 .AND. INCX.NE.0) ISAME(6) = LSE(XS,X,1,N,ABS(INCX)) ISAME(7) = INCXS .EQ. INCX ISAME(8) = BLS .EQ. BETA ISAME(9) = .TRUE. IF (N.GT.0 .AND. INCY.NE.0) ISAME(9) = LSE(YS,Y,1,N,ABS(INCY)) ISAME(10) = INCYS .EQ. INCY * ELSE IF (ISNUM.EQ.4) THEN C COMPARE THE MATRIX IN THE SSBMV AND SSPMV DATA STRUCTURES WITH C THE SAVED COPY. ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS) ISAME(2) = NS .EQ. N ISAME(3) = KS .EQ. K ISAME(4) = ALS .EQ. ALPHA ISAME(5) = .TRUE. C TEST THE MATRIX IN THE DATA STRUCTURE USED WITH SSBMV. IF (ICHAR(ICI).EQ.ICHAR('U')) THEN KOFF = K * ELSE KOFF = 0 END IF * IF (N.GT.0) THEN DO 240 J = 1,N DO 230 I = MAX(1,J-K),MIN(N,J+K) IF (AS(1+ (I-1)+ (J-1)*LDA).NE. . A(1+ (KOFF+I-J)+ (J-1)*LDA)) THEN ISAME(5) = .FALSE. GO TO 250 * END IF * 230 CONTINUE 240 CONTINUE 250 CONTINUE END IF * ISAME(6) = LDAS .EQ. LDA ISAME(7) = .TRUE. IF (N.GT.0 .AND. INCX.NE.0) ISAME(7) = LSE(XS,X,1,N,ABS(INCX)) ISAME(8) = INCXS .EQ. INCX ISAME(9) = BLS .EQ. BETA ISAME(10) = .TRUE. IF (N.GT.0 .AND. INCY.NE.0) ISAME(10) = LSE(YS,Y,1,N, . ABS(INCY)) ISAME(11) = INCYS .EQ. INCY * ELSE IF (ISNUM.EQ.5) THEN ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS) ISAME(2) = NS .EQ. N ISAME(3) = ALS .EQ. ALPHA ISAME(4) = .TRUE. C TEST THE MATRIX USING THE DATA STRUCTURE USED WITH SSPMV. IOFF = 0 DO 270 J = 1,N IF (ICHAR(ICI).EQ.ICHAR('U')) THEN ISTRT = 1 IEND = J * ELSE ISTRT = J IEND = N END IF * DO 260 I = ISTRT,IEND IOFF = IOFF + 1 IF (A(IOFF).NE.AS(1+ (I-1)+ (J-1)*LDA)) THEN ISAME(4) = .FALSE. GO TO 280 * END IF * 260 CONTINUE * 270 CONTINUE 280 CONTINUE ISAME(5) = .TRUE. IF (N.GT.0 .AND. INCX.NE.0) ISAME(5) = LSE(XS,X,1,N,ABS(INCX)) ISAME(6) = INCXS .EQ. INCX ISAME(7) = BLS .EQ. BETA ISAME(8) = .TRUE. IF (N.GT.0 .AND. INCY.NE.0) ISAME(8) = LSE(YS,Y,1,N,ABS(INCY)) ISAME(9) = INCYS .EQ. INCY END IF * GO TO IGO2 * 290 CONTINUE C PROCEDURE (CALL SUBROUTINE) C SAVE EVERY DATUM BEFORE THE CALL. ICHS = ICI NS = N KS = K ALS = ALPHA DO 300 I = 1,N*N AS(I) = A(I) 300 CONTINUE LDAS = LDA C SAVE COPY OF THE X AND Y VECTORS. IBX = 1 IF (INCX.LT.0) IBX = 1 + (1-N)*INCX DO 310 J = 1,N XS(IBX+ (J-1)*INCX) = X(IBX+ (J-1)*INCX) 310 CONTINUE INCXS = INCX BLS = BETA IBY = 1 IF (INCY.LT.0) IBY = 1 + (1-N)*INCY DO 320 I = 1,N YS(IBY+ (I-1)*INCY) = Y(IBY+ (I-1)*INCY) 320 CONTINUE INCYS = INCY IF (ISNUM.EQ.3) THEN CALL SSYMV(ICI,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * ELSE IF (ISNUM.EQ.4) THEN C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH SSBMV. IF (ICHAR(ICI).EQ.ICHAR('U')) THEN KOFF = K * ELSE KOFF = 0 END IF * DO 340 J = 1,N DO 330 I = MAX(1,J-K),MIN(N,J+K) A(1+ (KOFF+I-J)+ (J-1)*LDA) = AS(1+ (I-1)+ (J-1)*LDA) 330 CONTINUE 340 CONTINUE CALL SSBMV(ICI,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) * ELSE IF (ISNUM.EQ.5) THEN C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH SSPMV. IOFF = 0 DO 360 J = 1,N IF (ICHAR(ICI).EQ.ICHAR('U')) THEN ISTRT = 1 IEND = J * ELSE ISTRT = J IEND = N END IF * DO 350 I = ISTRT,IEND IOFF = IOFF + 1 A(IOFF) = AS(1+ (I-1)+ (J-1)*LDA) 350 CONTINUE * 360 CONTINUE CALL SSPMV(ICI,N,ALPHA,A,X,INCX,BETA,Y,INCY) END IF * GO TO IGO1 * 370 CONTINUE C PROCEDURE (DEFINE A SET OF PROBLEM DATA) C DO NOTHING IF DIMENSIONS ARE NOT POSITIVE. IF (N.LE.0) GO TO IGO3 TRANSL = ZERO CALL SMAKE(A,N,N,LDA,RESET,TRANSL) C MAKE THE DATA MATRIX SYMMETRIC. DO 390 I = 1,N DO 380 J = I,N T = (A(1+ (I-1)+ (J-1)*LDA)+A(1+ (J-1)+ (I-1)*LDA))*HALF A(1+ (I-1)+ (J-1)*LDA) = T A(1+ (J-1)+ (I-1)*LDA) = T 380 CONTINUE 390 CONTINUE C TRIM AWAY ELEMENTS OUTSIDE THE BANDWIDTH FOR SSBMV. IF (ISNUM.EQ.4) THEN DO 410 J = 1,N DO 400 I = 1,N T = A(1+ (I-1)+ (J-1)*LDA) IF (J.GT.I .AND. J-I.GT.K) T = ZERO IF (I.GT.J .AND. I-J.GT.K) T = ZERO A(1+ (I-1)+ (J-1)*LDA) = T 400 CONTINUE 410 CONTINUE END IF * TRANSL = 500.E0 RESET = .FALSE. CALL SMAKE(X,1,N,MAX(1,ABS(INCX)),RESET,TRANSL) IF (N.GT.1 .AND. INCX.EQ.1) X(N/2) = ZERO TRANSL = ZERO CALL SMAKE(Y,1,N,MAX(1,ABS(INCY)),RESET,TRANSL) GO TO IGO3 * 420 CONTINUE C PROCEDURE (COMPUTE A CORRECT RESULT) C COMPUTE THE CONDITION NUMBER TO USE AS GAUGE FOR ACCURATE RESULTS. C THIS IS RETURNED IN XT(*). C COMPUTE THE APPROXIMATE CORRECT RESULT. C THIS IS RETURNED IN YT(*). IF (INCY.LT.0) THEN IBY = (1-N)*INCY + 1 * ELSE IBY = 1 END IF * DO 440 I = 1,N YT(I) = BETA*YS(IBY+ (I-1)*INCY) XT(I) = YS(IBY+ (I-1)*INCY)**2 IF (INCX.LT.0) THEN IBX = (1-N)*INCX + 1 * ELSE IBX = 1 END IF * DO 430 J = 1,N YT(I) = YT(I) + AS(1+ (I-1)+ (J-1)*LDA)*ALPHA* . XS(IBX+ (J-1)*INCX) XT(I) = XT(I) + AS(1+ (I-1)+ (J-1)*LDA)**2 430 CONTINUE XT(I) = SQRT(XT(I)) 440 CONTINUE XN = BETA**2 DO 450 J = 1,N XN = XN + XS(IBX+ (J-1)*INCX)**2 450 CONTINUE XN = SQRT(XN) C COMPUTE THE GAUGES FOR THE RESULTS. DO 460 I = 1,N XT(I) = XT(I)*XN 460 CONTINUE C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS. DO 470 I = 1,N YT(I) = YT(I) - Y(IBY+ (I-1)*INCY) 470 CONTINUE C COMPUTE THE GRADE OF THIS RESULT. IGR = 0 T = ONE 480 CONTINUE C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING. IF (IGR.GT.IG) GO TO 510 DO 490 I = 1,N IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 490 T = T*HALF IGR = IGR + 1 GO TO 480 * 490 CONTINUE C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE C PROBLEMS. 500 CONTINUE AVIGR = MAX(AVIGR,REAL(IGR)) GO TO IGO4 * 510 CONTINUE FATAL = .TRUE. GO TO 500 * * LAST EXECUTABLE LINE OF SCHCK2 9001 FORMAT (' IN SUBPROGRAM ',A,/,' TESTS ACTIVE WITH OPTION = ',A,/, . ' N = ',I4,/,' INCX = ',I2,', INCY = ',I2,/,' K =',I4) 9011 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2, . ' WAS CHANGED WITH INVALID INPUT.',/,' OPTION = ',A,/,' N = ', . I4,/,' INCX = ',I2,', INCY = ',I2,/,' K = ',I4) 9021 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2, . ' WAS CHANGED WHILE COMPUTING',/,' OPTION = ',A,/,' N = ',I4,/, . ' INCX = ',I2,', INCY = ',I2,/,' K = ',I4) 9031 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'RECEIVED A LOSS GRADE OF ', . F5.2,' OUT OF ',I3) 9041 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'FAILED.') 9051 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'NOT TESTED.') END SUBROUTINE SCHCK3(ISNUM,SNAME,IG,DOPE,NUNIT,AVIGR,FATAL) C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS. C TEST STRMV, 06, STBMV, 07, STPMV, 08, C STRSV, 09, STBSV, 10, AND STPSV, 11. C REVISED 860623 C REVISED YYMMDD C AUTH=R. J. HANSON, SANDIA NATIONAL LABS. C THIS PROGRAM HAS TWO PARTS. THE FIRST PART CHECKS TO SEE C IF ANY DATA GETS CHANGED WHEN NONE SHOULD. FOR EXAMPLE WHEN C USING AN INVALID OPTION OR NONPOSITVE PROBLEM DIMENSIONS. C THE SECOND PART CHECKS THAT THE RESULTS ARE REASONABLY ACCURATE. C DIMENSION AND PROBLEM SIZE DATA.. INTEGER INC(04),IDIM(06),NUNIT(2) LOGICAL ISAME(13),LSE,FATAL,SAME,NCHNG,RESET CHARACTER *128 DOPE(2) CHARACTER *6 SNAME CHARACTER *3 ICHI,ICHJ,ICHK CHARACTER *1 ICIU,ICIT,ICID CHARACTER *1 ICIUS,ICITS,ICIDS INTEGER LA,LV PARAMETER (LA=4096,LV=4096,LMN=2048) REAL A(LA),AS(LA),X(LV),XS(LV) REAL Y(LV),YS(LV),YT(LMN),XT(LMN) PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0) COMMON /ARRAYS/AR,AS,X,XS,Y,YS,XT,YT EXTERNAL SDIFF * DATA INC/-2,-1,1,2/ DATA IDIM/1,2,4,8,64,0/ DATA ICHI/'LU/'/,ICHJ/'NT/'/,ICHK/'NU/'/ FATAL = .FALSE. C CHECK TRIANGULAR MATRIX-VECTOR PRODUCT, X = A*X, 6-8, C AND TRIANGULAR SOLVERS, 9-11. IF (ISNUM.LT.0) GO TO 180 NC = 0 RESET = .TRUE. AVIGR = ZERO IX = 0 10 IX = IX + 1 IF (IX.GT.4) GO TO 160 INCX = INC(IX) NN = 0 20 NN = NN + 1 IF (NN.GT.6) GO TO 150 N = IDIM(NN) IC = 0 30 IC = IC + 1 IF (IC.GT.3) GO TO 140 IF (FATAL) GO TO 170 ICIU = ICHI(IC:IC) ICIT = ICHJ(IC:IC) ICID = ICHK(IC:IC) C DEFINE DEFAULT VALUE OF K SO PRINTING IS OK. K = MAX(0,N-1) C DEFINE THE NUMBER OF ARGUMENTS AND THE X ARGUMENT NUMBER. LDA = MAX(N,1) IF (ICHAR(ICIT).EQ.ICHAR('T')) THEN INCRA = LDA INCCA = 1 * ELSE INCRA = 1 INCCA = LDA END IF * IF (ISNUM.EQ.6 .OR. ISNUM.EQ.9) THEN NARGS = 08 IXARG = 07 * ELSE IF (ISNUM.EQ.7 .OR. ISNUM.EQ.10) THEN NARGS = 09 IXARG = 08 C DEFINE BANDWIDTH OF MATRIX FOR TEST OF STBMV. K = INT(SQRT(REAL(N))+HALF) - 1 * ELSE IF (ISNUM.EQ.8 .OR. ISNUM.EQ.11) THEN NARGS = 07 IXARG = 06 END IF C DO (PREPARE NOTES FOR THIS TEST) C C PRINT A MESSAGE THAT GIVES DEBUGGING INFORMATION. THIS C MESSAGE SAYS.. C IN SUBPROGRAM XXXXX TESTS WERE ACTIVE WITH C OPTIONS = 'A' 'A' 'A' C N = IIII, C INCX = IIII C K = IIII. C THE MAIN IDEA HERE IS THAT A SERIOUS BUG THAT OCCURS DURING THE C TESTING OF THESE SUBPROGRAMS MAY LOSE PROGRAM CONTROL. THIS C AUXILLIARY FILE CONTAINS THE DIMENSIONS THAT RESULTED IN THE LOSS C OF CONTROL. HENCE IT PROVIDES THE IMPLEMENTOR WITH MORE COMPLETE C INFORMATION ABOUT WHERE TO START TRACKING DOWN THE BUG. IF (NUNIT(1).GT.0) THEN C IF UNIT IS NOT AVAILABLE WITH 'NEW' STATUS, OPEN WITH C 'OLD' AND THEN DELETE IT. ISTAT = 1 CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR) IF (IERROR.EQ.1) GO TO 40 C GET RID OF ANY OLD FILE. CLOSE (UNIT=NUNIT(1),STATUS='DELETE',ERR=40) 40 CONTINUE ISTAT = 2 C CREATE A NEW FILE FOR THE NEXT TEST. CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR) IF (IERROR.EQ.0) GO TO 60 50 CONTINUE NMESS = 7 C DO (PRINT A MESSAGE) C PRINT AN ERROR MESSAGE ABOUT OPENING THE NAME FILE. CALL SMESSG(0,1,NMESS) FATAL = .TRUE. GO TO 170 * 60 CONTINUE WRITE (NUNIT(1),9001) SNAME,ICIU,ICIT,ICID,N,INCX,K C CLOSE THE FILE SO USEFUL STATUS INFORMATION IS SEALED. CLOSE (UNIT=NUNIT(1)) END IF C DO (DEFINE A SET OF PROBLEM DATA) ASSIGN 70 TO IGO3 GO TO 330 * 70 CONTINUE C DO (CALL SUBROUTINE) ASSIGN 80 TO IGO1 GO TO 260 * 80 CONTINUE IF (N.LE.0 .OR. ICHAR(ICIU).EQ.ICHAR('/') .OR. ICHAR(ICIT).EQ. . ICHAR('/') .OR. ICHAR(ICID).EQ.ICHAR('/')) THEN C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES) ASSIGN 90 TO IGO2 GO TO 200 * 90 CONTINUE C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN. SAME = .TRUE. DO 100 I = 1,NARGS SAME = SAME .AND. ISAME(I) IF ( .NOT. ISAME(I)) THEN WRITE (NUNIT(2),9011) SNAME,I,ICIU,ICIT,ICID,N,INCX,K END IF * 100 CONTINUE IF ( .NOT. SAME) THEN FATAL = .TRUE. GO TO 170 * END IF * ELSE C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES) ASSIGN 110 TO IGO2 GO TO 200 * 110 CONTINUE C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN. SAME = .TRUE. DO 120 I = 1,NARGS NCHNG = (I.EQ.IXARG .OR. ISAME(I)) SAME = SAME .AND. NCHNG IF ( .NOT. NCHNG) THEN WRITE (NUNIT(2),9021) SNAME,I,ICIU,ICIT,ICID,N,INCX,K END IF * 120 CONTINUE IF ( .NOT. SAME) THEN FATAL = .TRUE. GO TO 170 * END IF * NC = NC + 1 C DO (COMPUTE A CORRECT RESULT) ASSIGN 130 TO IGO4 GO TO 380 * 130 CONTINUE C IF GOT REALLY BAD ANSWER, PRINT NOTE AND GO BACK. IF (FATAL) GO TO 160 * END IF * GO TO 30 * 140 CONTINUE GO TO 20 * 150 CONTINUE GO TO 10 * 160 CONTINUE C REPORT ON ACCURACY OF DATA. WRITE (NUNIT(2),9031) ISNUM,SNAME,AVIGR,IG GO TO 190 * 170 CONTINUE WRITE (NUNIT(2),9041) ISNUM,SNAME GO TO 190 * 180 CONTINUE WRITE (NUNIT(2),9051) - ISNUM,SNAME 190 CONTINUE RETURN * 200 CONTINUE C PROCEDURE (SEE WHAT DATA CHANGED INSIDE SUBROUTINES) ISAME(1) = ICHAR(ICIU) .EQ. ICHAR(ICIUS) ISAME(2) = ICHAR(ICIT) .EQ. ICHAR(ICITS) ISAME(3) = ICHAR(ICID) .EQ. ICHAR(ICIDS) ISAME(4) = NS .EQ. N IF (ISNUM.EQ.6 .OR. ISNUM.EQ.9) THEN ISAME(5) = .TRUE. IF (N.GT.0) ISAME(5) = LSE(AS,A,N,N,LDA) ISAME(6) = LDAS .EQ. LDA ISAME(7) = .TRUE. IF (N.GT.0) ISAME(7) = LSE(XS,X,1,N,ABS(INCX)) ISAME(8) = INCXS .EQ. INCX * ELSE IF (ISNUM.EQ.7 .OR. ISNUM.EQ.10) THEN C COMPARE THE MATRIX IN THE STBMV AND STPMV DATA STRUCTURES WITH C THE SAVED COPY. ISAME(5) = KS .EQ. K ISAME(6) = .TRUE. IF (N.GT.0) THEN DO 220 J = 1,N IF (ICHAR(ICIU).EQ.ICHAR('U')) THEN ISTRT = MAX(1,J-K) IEND = J * ELSE ISTRT = J IEND = MIN(N,J+K) END IF * DO 210 I = ISTRT,IEND IF (AS(1+ (I-1)+ (J-1)*LDA).NE. . A(1+ (KOFF+I-J)+ (J-1)*LDA)) THEN ISAME(6) = .FALSE. GO TO 230 * END IF * 210 CONTINUE 220 CONTINUE 230 CONTINUE END IF * ISAME(7) = LDAS .EQ. LDA ISAME(8) = .TRUE. IF (N.GT.0) ISAME(8) = LSE(XS,X,1,N,ABS(INCX)) ISAME(9) = INCXS .EQ. INCX * ELSE IF (ISNUM.EQ.8 .OR. ISNUM.EQ.11) THEN ISAME(5) = .TRUE. IOFF = 0 DO 250 J = 1,N IF (ICHAR(ICIU).EQ.ICHAR('U')) THEN ISTRT = 1 IEND = J * ELSE ISTRT = J IEND = N END IF * DO 240 I = ISTRT,IEND IOFF = IOFF + 1 IF (A(IOFF).NE.AS(1+ (I-1)+ (J-1)* . LDA)) ISAME(5) = .FALSE. 240 CONTINUE * 250 CONTINUE ISAME(6) = .TRUE. IF (N.GT.0) ISAME(6) = LSE(XS,X,1,N,ABS(INCX)) ISAME(7) = INCXS .EQ. INCX END IF * GO TO IGO2 * 260 CONTINUE C PROCEDURE (CALL SUBROUTINE) C SAVE EVERY DATUM BEFORE THE CALL. ICIUS = ICIU ICITS = ICIT ICIDS = ICID NS = N KS = K DO 270 I = 1,N*N AS(I) = A(I) 270 CONTINUE LDAS = LDA C SAVE COPY OF THE X VECTOR. IBX = 1 IF (INCX.LT.0) IBX = 1 + (1-N)*INCX DO 280 J = 1,N XS(IBX+ (J-1)*INCX) = X(IBX+ (J-1)*INCX) 280 CONTINUE INCXS = INCX IF (ISNUM.EQ.6) THEN CALL STRMV(ICIU,ICIT,ICID,N,A,LDA,X,INCX) * ELSE IF (ISNUM.EQ.9) THEN CALL STRSV(ICIU,ICIT,ICID,N,A,LDA,X,INCX) * ELSE IF (ISNUM.EQ.7 .OR. ISNUM.EQ.10) THEN C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH STBMV. IF (ICHAR(ICIU).EQ.ICHAR('U')) THEN KOFF = K * ELSE KOFF = 0 END IF * DO 300 J = 1,N IF (ICHAR(ICIU).EQ.ICHAR('U')) THEN ISTRT = MAX(1,J-K) IEND = J * ELSE ISTRT = J IEND = MIN(N,J+K) END IF * DO 290 I = ISTRT,IEND A(1+ (KOFF+I-J)+ (J-1)*LDA) = AS(1+ (I-1)+ (J-1)*LDA) 290 CONTINUE 300 CONTINUE IF (ISNUM.EQ.7) CALL STBMV(ICIU,ICIT,ICID,N,K,A,LDA,X,INCX) IF (ISNUM.EQ.10) CALL STBSV(ICIU,ICIT,ICID,N,K,A,LDA,X,INCX) * ELSE IF (ISNUM.EQ.8 .OR. ISNUM.EQ.11) THEN C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH STPMV. IOFF = 0 DO 320 J = 1,N IF (ICHAR(ICIU).EQ.ICHAR('U')) THEN ISTRT = 1 IEND = J * ELSE ISTRT = J IEND = N END IF * DO 310 I = ISTRT,IEND IOFF = IOFF + 1 A(IOFF) = AS(1+ (I-1)+ (J-1)*LDA) 310 CONTINUE * 320 CONTINUE IF (ISNUM.EQ.8) CALL STPMV(ICIU,ICIT,ICID,N,A,X,INCX) IF (ISNUM.EQ.11) CALL STPSV(ICIU,ICIT,ICID,N,A,X,INCX) END IF * GO TO IGO1 * 330 CONTINUE C PROCEDURE (DEFINE A SET OF PROBLEM DATA) C DO NOTHING IF DIMENSIONS ARE NOT POSITIVE. IF (N.LE.0) GO TO IGO3 TRANSL = ZERO CALL SMAKE(A,N,N,LDA,RESET,TRANSL) C MAKE THE DATA MATRIX TRIANGULAR. DO 350 I = 1,N DO 340 J = 1,N T = A(1+INCRA* (I-1)+ (J-1)*INCCA) S = A(1+INCRA* (J-1)+ (I-1)*INCCA) C SCALE TERMS SO THAT UNIT MATRICES ARE WELL-CONDITIONED. S = S/1000.E0 T = T/1000.E0 IF (ICHAR(ICIU).EQ.ICHAR('L') .AND. I.LT.J) T = ZERO IF (ICHAR(ICIU).EQ.ICHAR('U') .AND. I.GT.J) S = ZERO IF (ICHAR(ICID).EQ.ICHAR('U') .AND. I.EQ.J) THEN S = ONE T = ONE END IF * A(1+INCRA* (I-1)+ (J-1)*INCCA) = T A(1+INCRA* (J-1)+ (I-1)*INCCA) = S 340 CONTINUE 350 CONTINUE C TRIM AWAY ELEMENTS OUTSIDE THE BANDWIDTH FOR STBMV. IF (ISNUM.EQ.7 .OR. ISNUM.EQ.10) THEN DO 370 I = 1,N DO 360 J = 1,N T = A(1+INCRA* (I-1)+ (J-1)*INCCA) IF (J.GT.I .AND. J-I.GT.K) T = ZERO IF (I.GT.J .AND. I-J.GT.K) T = ZERO A(1+INCRA* (I-1)+ (J-1)*INCCA) = T 360 CONTINUE 370 CONTINUE END IF * TRANSL = 500.E0 RESET = .FALSE. CALL SMAKE(X,1,N,MAX(1,ABS(INCX)),RESET,TRANSL) IF (N.GT.1 .AND. INCX.EQ.1) X(N/2) = ZERO GO TO IGO3 * 380 CONTINUE C PROCEDURE (COMPUTE A CORRECT RESULT) C COMPUTE THE CONDITION NUMBER TO USE AS GAUGE FOR ACCURATE RESULTS. C THIS IS RETURNED IN XT(*). C COMPUTE THE APPROXIMATE CORRECT RESULT. C THIS IS RETURNED IN YT(*). DO 400 I = 1,N YT(I) = ZERO XT(I) = ZERO IF (INCX.LT.0) THEN IBX = (1-N)*INCX + 1 * ELSE IBX = 1 END IF * DO 390 J = 1,N T = XS(IBX+ (J-1)*INCX) IF (ISNUM.GE.9) T = X(IBX+ (J-1)*INCX) YT(I) = YT(I) + AS(1+ (I-1)*INCRA+ (J-1)*INCCA)*T XT(I) = XT(I) + AS(1+ (I-1)*INCRA+ (J-1)*INCCA)**2 390 CONTINUE XT(I) = SQRT(XT(I)) 400 CONTINUE XN = ZERO DO 410 J = 1,N T = XS(IBX+ (J-1)*INCX) IF (ISNUM.GE.9) T = X(IBX+ (J-1)*INCX) XN = XN + T**2 410 CONTINUE XN = SQRT(XN) C COMPUTE THE GAUGES FOR THE RESULTS. DO 420 I = 1,N XT(I) = XT(I)*XN 420 CONTINUE C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS. DO 430 I = 1,N T = X(IBX+ (I-1)*INCX) IF (ISNUM.GE.9) T = XS(IBX+ (I-1)*INCX) YT(I) = YT(I) - T 430 CONTINUE C COMPUTE THE GRADE OF THIS RESULT. IGR = 0 T = ONE 440 CONTINUE C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING. IF (IGR.GE.IG) GO TO 470 DO 450 I = 1,N IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 450 T = T*HALF IGR = IGR + 1 GO TO 440 * 450 CONTINUE C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE C PROBLEMS. 460 CONTINUE AVIGR = MAX(AVIGR,REAL(IGR)) GO TO IGO4 * 470 CONTINUE FATAL = .TRUE. GO TO 460 * * LAST EXECUTABLE LINE OF SCHCK3 9001 FORMAT (' IN SUBPROGRAM ',A,/,' TESTS ACTIVE WITH OPTIONS = ', . 3 (A,2X),/,' N = ',I4,/,' INCX = ',I2,/,' K =',I4) 9011 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2, . ' WAS CHANGED WITH INVALID INPUT.',/,' OPTIONS = ',3 (A,2X),/, . ' N = ',I4,/,' INCX = ',I2,/,' K = ',I4) 9021 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2, . ' WAS CHANGED WHILE COMPUTING',/,' OPTIONS = ',3 (A,2X),/, . ' N = ',I4,/,' INCX = ',I2,/,' K = ',I4) 9031 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'RECEIVED A LOSS GRADE OF ', . F5.2,' OUT OF ',I3) 9041 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'FAILED.') 9051 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'NOT TESTED.') END SUBROUTINE SCHCK4(ISNUM,SNAME,IG,DOPE,NUNIT,AVIGR,FATAL) C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS. C TEST SGER, 12. C REVISED 860623 C REVISED YYMMDD C AUTH=R. J. HANSON, SANDIA NATIONAL LABS. C THIS PROGRAM HAS TWO PARTS. THE FIRST PART CHECKS TO SEE C IF ANY DATA GETS CHANGED WHEN NONE SHOULD. FOR EXAMPLE WHEN C USING AN INVALID OPTION OR NONPOSITVE PROBLEM DIMENSIONS. C THE SECOND PART CHECKS THAT THE RESULTS ARE REASONABLY ACCURATE. C DIMENSION AND PROBLEM SIZE DATA.. INTEGER INC(04),IDIM(08),NUNIT(2) REAL ALF(04),SDIFF LOGICAL ISAME(13),LSE,FATAL,SAME,NCHNG,RESET CHARACTER *128 DOPE(2) CHARACTER *6 SNAME INTEGER LA,LV PARAMETER (LA=4096,LV=4096,LMN=2048) REAL A(LA),AS(LA),X(LV),XS(LV) REAL Y(LV),YS(LV),YT(LMN),XT(LMN) PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0) COMMON /ARRAYS/AR,AS,X,XS,Y,YS,YT,XT EXTERNAL SDIFF * DATA ALF/-1.E0,2.E0,.3E0,1.E0/ DATA INC/-2,-1,1,2/ DATA IDIM/1,2,4,8,64,128,2048,0/ FATAL = .FALSE. C CHECK GENERAL RANK 1 UPDATE, 12. IF (ISNUM.LT.0) GO TO 200 NC = 0 RESET = .TRUE. AVIGR = ZERO IX = 0 10 IX = IX + 1 IF (IX.GT.4) GO TO 180 INCX = INC(IX) ALPHA = ALF(IX) IY = 0 20 IY = IY + 1 IF (IY.GT.4) GO TO 170 INCY = INC(IY) MM = 0 30 MM = MM + 1 IF (MM.GT.8) GO TO 160 M = IDIM(MM) NN = 0 40 NN = NN + 1 IF (NN.GT.8) GO TO 150 N = IDIM(NN) IF (FATAL) GO TO 190 ML = N NL = M INCCA = M INCRA = 1 C DEFINE THE NUMBER OF ARGUMENTS AND THE A ARGUMENT NUMBER. LDA = MAX(M,1) NARGS = 09 IAARG = 08 C IF NOT ENOUGH STORAGE, SKIP THIS CASE. (AVOID EXPLICT M*N). IF (SQRT(REAL(N))*SQRT(REAL(M)).GT.SQRT(REAL(LA))) GO TO 40 C DO (PREPARE NOTES FOR THIS TEST) C C PRINT A MESSAGE THAT GIVES DEBUGGING INFORMATION. THIS C MESSAGE SAYS.. C IN SUBPROGRAM XXXXX TESTS WERE ACTIVE WITH C M = IIII, N = IIII, C INCX = IIII, INCY = IIII, C THE MAIN IDEA HERE IS THAT A SERIOUS BUG THAT OCCURS DURING THE C TESTING OF THESE SUBPROGRAMS MAY LOSE PROGRAM CONTROL. THIS C AUXILLIARY FILE CONTAINS THE DIMENSIONS THAT RESULTED IN THE LOSS C OF CONTROL. HENCE IT PROVIDES THE IMPLEMENTOR WITH MORE COMPLETE C INFORMATION ABOUT WHERE TO START TRACKING DOWN THE BUG. IF (NUNIT(1).GT.0) THEN C IF UNIT IS NOT AVAILABLE WITH 'NEW' STATUS, OPEN WITH C 'OLD' AND THEN DELETE IT. ISTAT = 1 CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR) IF (IERROR.EQ.1) GO TO 50 C GET RID OF ANY OLD FILE. CLOSE (UNIT=NUNIT(1),STATUS='DELETE',ERR=50) 50 CONTINUE ISTAT = 2 C CREATE A NEW FILE FOR THE NEXT TEST. CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR) IF (IERROR.EQ.0) GO TO 70 60 CONTINUE NMESS = 7 C DO (PRINT A MESSAGE) C PRINT AN ERROR MESSAGE ABOUT OPENING THE NAME FILE. CALL SMESSG(0,1,NMESS) FATAL = .TRUE. GO TO 190 * 70 CONTINUE WRITE (NUNIT(1),9001) SNAME,M,N,INCX,INCY C CLOSE THE FILE SO USEFUL STATUS INFORMATION IS SEALED. CLOSE (UNIT=NUNIT(1)) END IF C DO (DEFINE A SET OF PROBLEM DATA) ASSIGN 80 TO IGO3 GO TO 270 * 80 CONTINUE C DO (CALL SUBROUTINE) ASSIGN 90 TO IGO1 GO TO 230 * 90 CONTINUE IF (M.LE.0 .OR. N.LE.0) THEN C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES) ASSIGN 100 TO IGO2 GO TO 220 * 100 CONTINUE C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN. SAME = .TRUE. DO 110 I = 1,NARGS SAME = SAME .AND. ISAME(I) IF ( .NOT. ISAME(I)) THEN WRITE (NUNIT(2),9011) SNAME,I,M,N,INCX,INCY END IF * 110 CONTINUE IF ( .NOT. SAME) THEN FATAL = .TRUE. GO TO 190 * END IF * ELSE C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES) ASSIGN 120 TO IGO2 GO TO 220 * 120 CONTINUE C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN. SAME = .TRUE. DO 130 I = 1,NARGS NCHNG = (I.EQ.IAARG .OR. ISAME(I)) SAME = SAME .AND. NCHNG IF ( .NOT. NCHNG) THEN WRITE (NUNIT(2),9021) SNAME,I,M,N,INCX,INCY END IF * 130 CONTINUE IF ( .NOT. SAME) THEN FATAL = .TRUE. GO TO 190 * END IF * NC = NC + 1 C DO (COMPUTE A CORRECT RESULT) ASSIGN 140 TO IGO4 GO TO 280 * 140 CONTINUE C IF GOT REALLY BAD ANSWER, PRINT NOTE AND GO BACK. IF (FATAL) GO TO 180 * END IF * GO TO 40 * 150 CONTINUE GO TO 30 * 160 CONTINUE GO TO 20 * 170 CONTINUE GO TO 10 * 180 CONTINUE C REPORT ON ACCURACY OF DATA. WRITE (NUNIT(2),9031) ISNUM,SNAME,AVIGR,IG GO TO 210 * 190 CONTINUE WRITE (NUNIT(2),9041) ISNUM,SNAME GO TO 210 * 200 CONTINUE WRITE (NUNIT(2),9051) - ISNUM,SNAME 210 CONTINUE RETURN * 220 CONTINUE C PROCEDURE (SEE WHAT DATA CHANGED INSIDE SUBROUTINES) ISAME(1) = MS .EQ. M ISAME(2) = NS .EQ. N ISAME(3) = ALS .EQ. ALPHA ISAME(4) = .TRUE. IF (NL.GT.0 .AND. INCX.NE.0) ISAME(4) = LSE(XS,X,1,NL,ABS(INCX)) ISAME(5) = INCXS .EQ. INCX ISAME(6) = .TRUE. IF (ML.GT.0 .AND. INCY.NE.0) ISAME(6) = LSE(YS,Y,1,ML,ABS(INCY)) ISAME(7) = INCYS .EQ. INCY ISAME(8) = .TRUE. IF (M.GT.0 .AND. N.GT.0) ISAME(8) = LSE(AS,A,M,N,LDA) ISAME(9) = LDAS .EQ. LDA * GO TO IGO2 * 230 CONTINUE C PROCEDURE (CALL SUBROUTINE) C SAVE EVERY DATUM BEFORE THE CALL. MS = M NS = N ALS = ALPHA DO 240 I = 1,M*N AS(I) = A(I) 240 CONTINUE LDAS = LDA C SAVE COPY OF THE X AND Y VECTORS. IBX = 1 IF (INCX.LT.0) IBX = 1 + (1-NL)*INCX DO 250 J = 1,NL XS(IBX+ (J-1)*INCX) = X(IBX+ (J-1)*INCX) 250 CONTINUE INCXS = INCX IBY = 1 IF (INCY.LT.0) IBY = 1 + (1-ML)*INCY DO 260 I = 1,ML YS(IBY+ (I-1)*INCY) = Y(IBY+ (I-1)*INCY) 260 CONTINUE INCYS = INCY CALL SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) * GO TO IGO1 * 270 CONTINUE C PROCEDURE (DEFINE A SET OF PROBLEM DATA) C DO NOTHING IF BOTH DIMENSIONS ARE NOT POSITIVE. IF (M.LE.0 .OR. N.LE.0) GO TO IGO3 TRANSL = ZERO CALL SMAKE(A,M,N,LDA,RESET,TRANSL) * TRANSL = 500.E0 RESET = .FALSE. CALL SMAKE(X,1,NL,MAX(1,ABS(INCX)),RESET,TRANSL) IF (NL.GT.1 .AND. INCX.EQ.1) X(NL/2) = ZERO TRANSL = ZERO CALL SMAKE(Y,1,ML,MAX(1,ABS(INCY)),RESET,TRANSL) GO TO IGO3 * 280 CONTINUE C PROCEDURE (COMPUTE A CORRECT RESULT) C COMPUTE THE CONDITION NUMBER TO USE AS GAUGE FOR ACCURATE RESULTS. C THIS IS RETURNED IN XT(*). C COMPUTE THE APPROXIMATE CORRECT RESULT. C THIS IS RETURNED IN YT(*), COLUMN BY COLUMN. IF (INCY.LT.0) THEN IBY = (1-ML)*INCY + 1 * ELSE IBY = 1 END IF * DO 340 J = 1,N DO 290 I = 1,M IF (INCX.LT.0) THEN IBX = (1-NL)*INCX + 1 * ELSE IBX = 1 END IF * YT(I) = AS(1+ (I-1)*INCRA+ (J-1)*INCCA) + . ALPHA*XS(IBX+ (I-1)*INCX)*YS(IBY+ (J-1)*INCY) XT(I) = AS(1+ (I-1)*INCRA+ (J-1)*INCCA)**2 + . ALPHA**2*XS(IBX+ (I-1)*INCX)**2* . YS(IBY+ (J-1)*INCY)**2 C COMPUTE THE GAUGES FOR THE RESULTS. XT(I) = SQRT(XT(I)) 290 CONTINUE C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS. DO 300 I = 1,M YT(I) = YT(I) - A(1+ (I-1)*INCRA+ (J-1)*INCCA) 300 CONTINUE C COMPUTE THE GRADE OF THIS RESULT. IGR = 0 T = ONE 310 CONTINUE C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING. IF (IGR.GE.IG) GO TO 360 DO 320 I = 1,M IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 320 T = T*HALF IGR = IGR + 1 GO TO 310 * 320 CONTINUE C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE C PROBLEMS. 330 CONTINUE 340 CONTINUE 350 AVIGR = MAX(AVIGR,REAL(IGR)) GO TO IGO4 * 360 CONTINUE FATAL = .TRUE. GO TO 350 * * LAST EXECUTABLE LINE OF SCHCK4 9001 FORMAT (' IN SUBPROGRAM ',A,/,' M =',I4,', N = ',I4,/,' INCX = ', . I2,', INCY = ',I2) 9011 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2, . ' WAS CHANGED WITH INVALID INPUT.',/,' M =',I4,', N = ',I4,/, . ' INCX = ',I2,', INCY = ',I2) 9021 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2, . ' WAS CHANGED WHILE COMPUTING',/,' M =',I4,', N = ',I4,/, . ' INCX = ',I2,', INCY = ',I2) 9031 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'RECEIVED A LOSS GRADE OF ', . F5.2,' OUT OF ',I3) 9041 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'FAILED.') 9051 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'NOT TESTED.') END SUBROUTINE SCHCK5(ISNUM,SNAME,IG,DOPE,NUNIT,AVIGR,FATAL) C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS. C TEST SSYR, 13, SSPR, 14, SSYR2, 15, AND SSPR2,16. C REVISED 860623 C REVISED YYMMDD C AUTH=R. J. HANSON, SANDIA NATIONAL LABS. C THIS PROGRAM HAS TWO PARTS. THE FIRST PART CHECKS TO SEE C IF ANY DATA GETS CHANGED WHEN NONE SHOULD. FOR EXAMPLE WHEN C USING AN INVALID OPTION OR NONPOSITVE PROBLEM DIMENSIONS. C THE SECOND PART CHECKS THAT THE RESULTS ARE REASONABLY ACCURATE. C DIMENSION AND PROBLEM SIZE DATA.. INTEGER INC(04),IDIM(06),NUNIT(2) REAL ALF(04) LOGICAL ISAME(13),LSE,FATAL,SAME,NCHNG,RESET CHARACTER *128 DOPE(2) CHARACTER *6 SNAME CHARACTER *3 ICH CHARACTER *1 ICHS,ICI INTEGER LA,LV PARAMETER (LA=4096,LV=4096,LMN=2048) REAL A(LA),AS(LA),X(LV),XS(LV) REAL Y(LV),YS(LV),YT(LMN),XT(LMN) PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0) COMMON /ARRAYS/AR,AS,X,XS,Y,YS,YT,XT EXTERNAL SDIFF * DATA ALF/-1.E0,2.E0,.3E0,1.E0/ DATA INC/-2,-1,1,2/ DATA IDIM/1,2,4,8,64,0/ DATA ICH/'LU/'/ FATAL = .FALSE. C CHECK SYMMETRIC MATRIX RANK 1 AND RANK 2 UPDATES. IF (ISNUM.LT.0) GO TO 200 NC = 0 RESET = .TRUE. AVIGR = ZERO IX = 0 10 IX = IX + 1 IF (IX.GT.4) GO TO 180 INCX = INC(IX) ALPHA = ALF(IX) IY = 0 20 IY = IY + 1 IF (IY.GT.4) GO TO 170 INCY = INC(IY) NN = 0 30 NN = NN + 1 IF (NN.GT.6) GO TO 160 N = IDIM(NN) IC = 0 40 IC = IC + 1 IF (IC.GT.3) GO TO 150 IF (FATAL) GO TO 190 ICI = ICH(IC:IC) C DEFINE THE NUMBER OF ARGUMENTS AND THE Y ARGUMENT NUMBER. LDA = MAX(N,1) IF (ISNUM.EQ.13) THEN NARGS = 07 IAARG = 06 * ELSE IF (ISNUM.EQ.14) THEN NARGS = 06 IAARG = 06 * ELSE IF (ISNUM.EQ.15) THEN NARGS = 9 IAARG = 8 * ELSE IF (ISNUM.EQ.16) THEN NARGS = 8 IAARG = 8 END IF C DO (PREPARE NOTES FOR THIS TEST) C C PRINT A MESSAGE THAT GIVES DEBUGGING INFORMATION. THIS C MESSAGE SAYS.. C IN SUBPROGRAM XXXXX TESTS WERE ACTIVE WITH C OPTION = 'A' C N = IIII, C INCX = IIII, INCY = IIII, C THE MAIN IDEA HERE IS THAT A SERIOUS BUG THAT OCCURS DURING THE C TESTING OF THESE SUBPROGRAMS MAY LOSE PROGRAM CONTROL. THIS C AUXILLIARY FILE CONTAINS THE DIMENSIONS THAT RESULTED IN THE LOSS C OF CONTROL. HENCE IT PROVIDES THE IMPLEMENTOR WITH MORE COMPLETE C INFORMATION ABOUT WHERE TO START TRACKING DOWN THE BUG. IF (NUNIT(1).GT.0) THEN C IF UNIT IS NOT AVAILABLE WITH 'NEW' STATUS, OPEN WITH C 'OLD' AND THEN DELETE IT. ISTAT = 1 CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR) IF (IERROR.EQ.1) GO TO 50 C GET RID OF ANY OLD FILE. CLOSE (UNIT=NUNIT(1),STATUS='DELETE',ERR=50) 50 CONTINUE ISTAT = 2 C CREATE A NEW FILE FOR THE NEXT TEST. CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR) IF (IERROR.EQ.0) GO TO 70 60 CONTINUE NMESS = 7 C DO (PRINT A MESSAGE) C PRINT AN ERROR MESSAGE ABOUT OPENING THE NAME FILE. CALL SMESSG(0,1,NMESS) FATAL = .TRUE. GO TO 190 * 70 CONTINUE WRITE (NUNIT(1),9001) SNAME,ICI,N,INCX,INCY C CLOSE THE FILE SO USEFUL STATUS INFORMATION IS SEALED. CLOSE (UNIT=NUNIT(1)) END IF C DO (DEFINE A SET OF PROBLEM DATA) ASSIGN 80 TO IGO3 GO TO 370 * 80 CONTINUE C DO (CALL SUBROUTINE) ASSIGN 90 TO IGO1 GO TO 290 * 90 CONTINUE IF (N.LE.0 .OR. ICHAR(ICI).EQ.ICHAR('/')) THEN C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES) ASSIGN 100 TO IGO2 GO TO 220 * 100 CONTINUE C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN. SAME = .TRUE. DO 110 I = 1,NARGS SAME = SAME .AND. ISAME(I) IF ( .NOT. ISAME(I)) THEN WRITE (NUNIT(2),9011) SNAME,I,ICI,N,INCX,INCY END IF * 110 CONTINUE IF ( .NOT. SAME) THEN FATAL = .TRUE. GO TO 190 * END IF * ELSE C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES) ASSIGN 120 TO IGO2 GO TO 220 * 120 CONTINUE C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN. SAME = .TRUE. DO 130 I = 1,NARGS NCHNG = (I.EQ.IAARG .OR. ISAME(I)) SAME = SAME .AND. NCHNG IF ( .NOT. NCHNG) THEN WRITE (NUNIT(2),9021) SNAME,I,ICI,N,INCX,INCY END IF * 130 CONTINUE IF ( .NOT. SAME) THEN FATAL = .TRUE. GO TO 190 * END IF * NC = NC + 1 C DO (COMPUTE A CORRECT RESULT) ASSIGN 140 TO IGO4 GO TO 400 * 140 CONTINUE C IF GOT REALLY BAD ANSWER, PRINT NOTE AND GO BACK. IF (FATAL) GO TO 180 * END IF * GO TO 40 * 150 CONTINUE GO TO 30 * 160 CONTINUE IF (ISNUM.GE.15) GO TO 20 GO TO 10 * 170 CONTINUE GO TO 10 * 180 CONTINUE C REPORT ON ACCURACY OF DATA. WRITE (NUNIT(2),9031) ISNUM,SNAME,AVIGR,IG GO TO 210 * 190 CONTINUE WRITE (NUNIT(2),9041) ISNUM,SNAME GO TO 210 * 200 CONTINUE WRITE (NUNIT(2),9051) - ISNUM,SNAME 210 CONTINUE RETURN * 220 CONTINUE C PROCEDURE (SEE WHAT DATA CHANGED INSIDE SUBROUTINES) IF (ISNUM.EQ.13) THEN ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS) ISAME(2) = NS .EQ. N ISAME(3) = ALS .EQ. ALPHA ISAME(4) = .TRUE. IF (N.GT.0 .AND. INCX.NE.0) ISAME(4) = LSE(XS,X,1,N,ABS(INCX)) ISAME(5) = INCXS .EQ. INCX ISAME(6) = .TRUE. IF (N.GT.0) ISAME(6) = LSE(AS,A,N,N,LDA) ISAME(7) = LDAS .EQ. LDA * ELSE IF (ISNUM.EQ.14) THEN C COMPARE THE MATRIX IN THE DATA STRUCTURES WITH THE SAVED COPY. ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS) ISAME(2) = NS .EQ. N ISAME(3) = ALS .EQ. ALPHA ISAME(4) = .TRUE. IF (N.GT.0 .AND. INCX.NE.0) ISAME(4) = LSE(XS,X,1,N,ABS(INCX)) ISAME(5) = INCXS .EQ. INCX ISAME(6) = .TRUE. IOFF = 0 DO 240 J = 1,N IF (ICHAR(ICI).EQ.ICHAR('U')) THEN ISTRT = 1 IEND = J * ELSE ISTRT = J IEND = N END IF * DO 230 I = ISTRT,IEND IOFF = IOFF + 1 IF (A(IOFF).NE.AS(1+ (I-1)+ (J-1)*LDA)) THEN ISAME(6) = .FALSE. GO TO 250 * END IF * 230 CONTINUE 240 CONTINUE 250 CONTINUE * ELSE IF (ISNUM.EQ.15) THEN ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS) ISAME(2) = NS .EQ. N ISAME(3) = ALS .EQ. ALPHA ISAME(4) = .TRUE. IF (N.GT.0 .AND. INCX.NE.0) ISAME(4) = LSE(XS,X,1,N,ABS(INCX)) ISAME(5) = INCXS .EQ. INCX ISAME(6) = .TRUE. IF (N.GT.0 .AND. INCY.NE.0) ISAME(6) = LSE(YS,Y,1,N,ABS(INCY)) ISAME(7) = INCYS .EQ. INCY ISAME(8) = .TRUE. IF (N.GT.0) ISAME(8) = LSE(AS,A,N,N,LDA) ISAME(9) = LDAS .EQ. LDA * ELSE IF (ISNUM.EQ.16) THEN ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS) ISAME(2) = NS .EQ. N ISAME(3) = ALS .EQ. ALPHA ISAME(4) = .TRUE. IF (N.GT.0 .AND. INCX.NE.0) ISAME(4) = LSE(XS,X,1,N,ABS(INCX)) ISAME(5) = INCXS .EQ. INCX ISAME(6) = .TRUE. IF (N.GT.0 .AND. INCY.NE.0) ISAME(6) = LSE(YS,Y,1,N,ABS(INCY)) ISAME(7) = INCYS .EQ. INCY ISAME(8) = .TRUE. IOFF = 0 DO 270 J = 1,N IF (ICHAR(ICI).EQ.ICHAR('U')) THEN ISTRT = 1 IEND = J * ELSE ISTRT = J IEND = N END IF * DO 260 I = ISTRT,IEND IOFF = IOFF + 1 IF (A(IOFF).NE.AS(1+ (I-1)+ (J-1)*LDA)) THEN ISAME(8) = .FALSE. GO TO 280 * END IF * 260 CONTINUE 270 CONTINUE 280 CONTINUE END IF * GO TO IGO2 * 290 CONTINUE C PROCEDURE (CALL SUBROUTINE) C SAVE EVERY DATUM BEFORE THE CALL. ICHS = ICI NS = N ALS = ALPHA DO 300 I = 1,N*N AS(I) = A(I) 300 CONTINUE LDAS = LDA C SAVE COPY OF THE X AND Y VECTORS. IBX = 1 IF (INCX.LT.0) IBX = 1 + (1-N)*INCX DO 310 J = 1,N XS(IBX+ (J-1)*INCX) = X(IBX+ (J-1)*INCX) 310 CONTINUE INCXS = INCX IBY = 1 IF (INCY.LT.0) IBY = 1 + (1-N)*INCY DO 320 I = 1,N YS(IBY+ (I-1)*INCY) = Y(IBY+ (I-1)*INCY) 320 CONTINUE INCYS = INCY IF (ISNUM.EQ.13) THEN CALL SSYR(ICI,N,ALPHA,X,INCX,A,LDA) * ELSE IF (ISNUM.EQ.14) THEN C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH SSPR. IOFF = 0 DO 340 J = 1,N IF (ICHAR(ICI).EQ.ICHAR('U')) THEN ISTRT = 1 IEND = J * ELSE ISTRT = J IEND = N END IF * DO 330 I = ISTRT,IEND IOFF = IOFF + 1 A(IOFF) = AS(1+ (I-1)+ (J-1)*LDA) 330 CONTINUE * 340 CONTINUE CALL SSPR(ICI,N,ALPHA,X,INCX,A) * ELSE IF (ISNUM.EQ.15) THEN * CALL SSYR2(ICI,N,ALPHA,X,INCX,Y,INCY,A,LDA) * ELSE IF (ISNUM.EQ.16) THEN C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH SSPR2. IOFF = 0 DO 360 J = 1,N IF (ICHAR(ICI).EQ.ICHAR('U')) THEN ISTRT = 1 IEND = J * ELSE ISTRT = J IEND = N END IF * DO 350 I = ISTRT,IEND IOFF = IOFF + 1 A(IOFF) = AS(1+ (I-1)+ (J-1)*LDA) 350 CONTINUE * 360 CONTINUE CALL SSPR2(ICI,N,ALPHA,X,INCX,Y,INCY,A) END IF * GO TO IGO1 * 370 CONTINUE C PROCEDURE (DEFINE A SET OF PROBLEM DATA) C DO NOTHING IF DIMENSIONS ARE NOT POSITIVE. IF (N.LE.0) GO TO IGO3 TRANSL = ZERO CALL SMAKE(A,N,N,LDA,RESET,TRANSL) C MAKE THE DATA MATRIX SYMMETRIC. DO 390 I = 1,N DO 380 J = I,N T = (A(1+ (I-1)+ (J-1)*LDA)+A(1+ (J-1)+ (I-1)*LDA))*HALF A(1+ (I-1)+ (J-1)*LDA) = T A(1+ (J-1)+ (I-1)*LDA) = T 380 CONTINUE 390 CONTINUE * TRANSL = 500.E0 RESET = .FALSE. CALL SMAKE(X,1,N,MAX(1,ABS(INCX)),RESET,TRANSL) IF (N.GT.1 .AND. INCX.EQ.1) X(N/2) = ZERO TRANSL = ZERO CALL SMAKE(Y,1,N,MAX(1,ABS(INCY)),RESET,TRANSL) GO TO IGO3 * 400 CONTINUE C PROCEDURE (COMPUTE A CORRECT RESULT) C COMPUTE THE CONDITION NUMBER TO USE AS GAUGE FOR ACCURATE RESULTS. C THIS IS RETURNED IN XT(*). C COMPUTE THE APPROXIMATE CORRECT RESULT. IF (ISNUM.EQ.13 .OR. ISNUM.EQ.14) THEN IF (INCX.LT.0) THEN IBX = (1-N)*INCX + 1 * ELSE IBX = 1 END IF * IOFF = 0 DO 450 J = 1,N IF (ICHAR(ICI).EQ.ICHAR('U')) THEN ISTRT = 1 IEND = J * ELSE ISTRT = J IEND = N END IF * DO 410 I = ISTRT,IEND YT(I) = AS(1+ (I-1)+ (J-1)*LDA) + . ALPHA*XS(IBX+ (J-1)*INCX)*XS(IBX+ (I-1)*INCX) XT(I) = AS(1+ (I-1)+ (J-1)*LDA)**2 + . ALPHA**2*XS(IBX+ (I-1)*INCX)**2* . XS(IBX+ (J-1)*INCX)**2 410 CONTINUE C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS. DO 420 I = ISTRT,IEND XT(I) = SQRT(XT(I)) IF (ISNUM.EQ.13) THEN YT(I) = YT(I) - A(1+ (I-1)+ (J-1)*LDA) * ELSE IF (ISNUM.EQ.14) THEN IOFF = IOFF + 1 YT(I) = YT(I) - A(IOFF) END IF * 420 CONTINUE C COMPUTE THE GRADE OF THIS RESULT. IGR = 0 T = ONE DO 440 I = ISTRT,IEND 430 CONTINUE C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING. IF (IGR.GE.IG) GO TO 520 IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 440 T = T*HALF IGR = IGR + 1 GO TO 430 * C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE C PROBLEMS. 440 CONTINUE 450 CONTINUE * ELSE IF (ISNUM.EQ.15 .OR. ISNUM.EQ.16) THEN IF (INCX.LT.0) THEN IBX = (1-N)*INCX + 1 * ELSE IBX = 1 END IF * IF (INCY.LT.0) THEN IBY = (1-N)*INCY + 1 * ELSE IBY = 1 END IF * IOFF = 0 DO 500 J = 1,N IF (ICHAR(ICI).EQ.ICHAR('U')) THEN ISTRT = 1 IEND = J * ELSE ISTRT = J IEND = N END IF * DO 460 I = ISTRT,IEND YT(I) = AS(1+ (I-1)+ (J-1)*LDA) + . ALPHA*XS(IBX+ (J-1)*INCX)*YS(IBY+ (I-1)*INCY) + . ALPHA*XS(IBX+ (I-1)*INCX)*YS(IBY+ (J-1)*INCY) XT(I) = AS(1+ (I-1)+ (J-1)*LDA)**2 + . ALPHA**2*XS(IBX+ (I-1)*INCX)**2* . YS(IBY+ (J-1)*INCY)**2 + . ALPHA**2*XS(IBX+ (J-1)*INCX)**2* . YS(IBY+ (I-1)*INCY)**2 460 CONTINUE C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS. DO 470 I = ISTRT,IEND XT(I) = SQRT(XT(I)) IF (ISNUM.EQ.15) THEN YT(I) = YT(I) - A(1+ (I-1)+ (J-1)*LDA) * ELSE IF (ISNUM.EQ.16) THEN IOFF = IOFF + 1 YT(I) = YT(I) - A(IOFF) END IF * 470 CONTINUE C COMPUTE THE GRADE OF THIS RESULT. IGR = 0 T = ONE DO 490 I = ISTRT,IEND 480 CONTINUE C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING. IF (IGR.GE.IG) GO TO 520 IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 490 T = T*HALF IGR = IGR + 1 GO TO 480 * C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE C PROBLEMS. 490 CONTINUE 500 CONTINUE END IF * 510 CONTINUE AVIGR = MAX(AVIGR,REAL(IGR)) GO TO IGO4 * 520 CONTINUE FATAL = .TRUE. GO TO 510 * * LAST EXECUTABLE LINE OF SCHCK5 9001 FORMAT (' IN SUBPROGRAM ',A,/,' TESTS ACTIVE WITH OPTION = ',A,/, . ' N = ',I4,/,' INCX = ',I2,', INCY = ',I2) 9011 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2, . ' WAS CHANGED WITH INVALID INPUT.',/,' OPTION = ',A,/,' N = ', . I4,/,' INCX = ',I2,', INCY = ',I2) 9021 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2, . ' WAS CHANGED WHILE COMPUTING',/,' OPTION = ',A,/,' N = ',I4,/, . ' INCX = ',I2,', INCY = ',I2) 9031 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'RECEIVED A LOSS GRADE OF ', . F5.2,' OUT OF ',I3) 9041 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'FAILED.') 9051 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'NOT TESTED.') END SUBROUTINE SMAKE(A,M,N,LDA,RESET,TRANS) C GENERATE VALUES FOR AN M BY N MATRIX A. C RESET THE GENERATOR IF FLAG RESET = .TRUE. C TRANSLATE THE VALUES WITH TRANS. C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS. C REVISED 860623 C REVISED YYMMDD C AUTH=R. J. HANSON, SANDIA NATIONAL LABS. REAL A(LDA,*),TRANS,ANOISE REAL ZERO,HALF,ONE PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0,THREE=3.E0) LOGICAL RESET IF (RESET) THEN ANOISE = -ONE ANOISE = SBEG(ANOISE) ANOISE = ZERO END IF * IC = 0 DO 20 I = 1,M DO 10 J = 1,N IC = IC + 1 C BREAK UP PERIODICITIES THAT ARE MULTIPLES OF 5. IF (MOD(IC,5).EQ.0) A(I,J) = SBEG(ANOISE) A(I,J) = SBEG(ANOISE) - TRANS C HERE THE PERTURBATION IN THE LAST BIT POSITION IS MADE. A(I,J) = A(I,J) + ONE/THREE ANOISE = 0.E0 10 CONTINUE 20 CONTINUE RETURN * LAST EXECUTABLE LINE OF SMAKE END SUBROUTINE SOPEN(IUNIT,NAME,ISTAT,IERROR) C OPEN UNIT IUNIT WITH FILE NAMED NAME. C ISTAT=1 FOR 'OLD', =2 FOR 'NEW', =3 FOR 'UNKNOWN'. C THE RETURN FLAG IERROR=0 FOR SUCCESS, =1 FOR FAILURE. C A BAD VALUE OF ISTAT CAN ALSO INDICATE FAILURE. C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS. C REVISED 860623 C REVISED YYMMDD C AUTH=R. J. HANSON, SANDIA NATIONAL LABS. CHARACTER * (*) NAME IF (ISTAT.EQ.1) OPEN (UNIT=IUNIT,FILE=NAME,STATUS='OLD',ERR=10) IF (ISTAT.EQ.2) OPEN (UNIT=IUNIT,FILE=NAME,STATUS='NEW',ERR=10) IF (ISTAT.EQ.3) OPEN (UNIT=IUNIT,FILE=NAME,STATUS='UNKNOWN', . ERR=10) GO TO (20,20,20),ISTAT * 10 CONTINUE IERROR = 1 GO TO 30 * 20 CONTINUE IERROR = 0 30 CONTINUE RETURN * LAST EXECUTABLE LINE OF SOPEN END FUNCTION SDIFF(X,Y) C C.L.LAWSON AND R.J.HANSON, JET PROPULSION LABORATORY, 1973 JUNE 7 C APPEARED IN 'SOLVING LEAST SQUARES PROBLEMS', PRENTICE-HALL, 1974 C THIS IS USED AS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS. C REVISED 860623 C REVISED YYMMDD C AUTH=R. J. HANSON, SANDIA NATIONAL LABS. SDIFF = X - Y RETURN * LAST EXECUTABLE LINE OF SDIFF END * FUNCTION SBEG(ANOISE) C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS. C REVISED 860623 C REVISED YYMMDD C AUTH=R. J. HANSON, SANDIA NATIONAL LABS. SAVE C GENERATE NUMBERS FOR CONSTRUCTION OF TEST CASES. IF (ANOISE) 10,30,20 10 MI = 891 MJ = 457 I = 7 J = 7 AJ = 0. SBEG = 0. RETURN * 20 J = J*MJ J = J - 997* (J/997) AJ = J - 498 C THE SEQUENCE OF VALUES OF I IS BOUNDED BETWEEN 1 AND 999 C IF INITIAL I = 1,2,3,6,7, OR 9, THE PERIOD WILL BE 50 C IF INITIAL I = 4 OR 8 THE PERIOD WILL BE 25 C IF INITIAL I = 5 THE PERIOD WILL BE 10 30 I = I*MI I = I - 1000* (I/1000) AI = I - 500 SBEG = AI + AJ*ANOISE RETURN * LAST EXECUTABLE LINE OF SBEG END * LOGICAL FUNCTION LSE(RI,RJ,M,N,LDI) C TEST IF TWO REAL ARRAYS ARE IDENTICAL. C THE ARRAYS ARE M BY N. C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS. C REVISED 860623 C REVISED YYMMDD C AUTH=R. J. HANSON, SANDIA NATIONAL LABS. REAL RI(LDI,*),RJ(LDI,*) DO 20 I = 1,M DO 10 J = 1,N IF (RI(I,J).NE.RJ(I,J)) THEN LSE = .FALSE. GO TO 30 * END IF * 10 CONTINUE 20 CONTINUE LSE = .TRUE. 30 CONTINUE RETURN * LAST EXECUTABLE LINE OF LSE END * LOGICAL FUNCTION LDE(DI,DJ,M,N,LDI) C TEST IF TWO DOUBLE PRECISION ARRAYS ARE IDENTICAL. C THE ARRAYS ARE M BY N. C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS. C REVISED 860623 C REVISED YYMMDD C AUTH=R. J. HANSON, SANDIA NATIONAL LABS. DOUBLE PRECISION DI(LDI,*),DJ(LDI,*) DO 20 I = 1,M DO 10 J = 1,N IF (DI(I,J).NE.DJ(I,J)) THEN LDE = .FALSE. GO TO 30 * END IF * 10 CONTINUE 20 CONTINUE LDE = .TRUE. 30 CONTINUE RETURN * LAST EXECUTABLE LINE OF LDE END * LOGICAL FUNCTION LCE(CI,CJ,M,N,LDI) C TEST IF TWO COMPLEX ARRAYS ARE IDENTICAL. C THE ARRAYS ARE M BY N. C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS. C REVISED 860623 C REVISED YYMMDD C AUTH=R. J. HANSON, SANDIA NATIONAL LABS. COMPLEX CI(LDI,*),CJ(LDI,*) DO 20 I = 1,M DO 10 J = 1,N IF (REAL(CI(I,J)).NE.REAL(CJ(I,J)) .OR. AIMAG(CI(I,J)).NE. . AIMAG(CJ(I,J))) THEN LCE = .FALSE. GO TO 30 * END IF * 10 CONTINUE 20 CONTINUE LCE = .TRUE. 30 CONTINUE RETURN * LAST EXECUTABLE LINE OF LCE END C C*********************************************************************** C C File of the REAL Level 2 BLAS routines: C C SGEMV, SGBMV, SSYMV, SSBMV, SSPMV, STRMV, STBMV, STPMV, C SGER , SSYR , SSPR , C SSYR2, SSPR2, C STRSV, STBSV, STPSV. C C See: C C Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. C A proposal for an extended set of Fortran Basic Linear Algebra C Subprograms. Technical Memorandum No.41 (revision 1), C Mathematics and Computer Science Division, Argone National C Laboratory, 9700 South Cass Avenue, Argonne, Illinois 60439, C USA, or NAG Technical Report TR4/85, Numerical Algorithms Group C Inc., 1101 31st Street, Suite 100, Downers Grove, Illinois C 60606-1263, USA. C C*********************************************************************** C SUBROUTINE SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) CHARACTER *1 TRANS INTEGER M,N,LDA,INCX,INCY REAL ALPHA,A(LDA,*),X(*),BETA,Y(*) * * Purpose * ======= * * SGEMV performs one of the matrix-vector operations * * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, * * where alpha and beta are scalars, x and y are vectors and A is an * m by n matrix. * * Parameters * ========== * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' y := alpha*A*x + beta*y. * * TRANS = 'T' y := alpha*A'*x + beta*y. * * TRANS = 'C' y := alpha*A'*x + beta*y *. * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the leading dimension of A as * declared in the calling (sub) program. LDA must be at least * max(m,1). * Unchanged on exit. * * X - REAL array of DIMENSION at least * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' * and at least * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. * Before entry, the incremented array X must contain the * vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. * Unchanged on exit. * * BETA - REAL * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then Y need not be set on input. * Unchanged on exit. * * Y - REAL array of DIMENSION at least * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' * and at least * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. * Before entry with BETA non-zero, the incremented array Y * must contain the vector y. On exit, Y is overwritten by the * updated vector y. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. * Unchanged on exit. * * * Note that TRANS, M, N and LDA must be such that the value of the * LOGICAL variable OK in the following statement is true. * * * * * Level 2 Blas routine. * * -- Written on 30-August-1985. * Sven Hammarling, Nag Central Office. C REVISED 860623 C REVISED YYMMDD C BY R. J. HANSON, SANDIA NATIONAL LABS. * INTEGER I,IX,IY,J,JX,JY INTEGER KX,KY,LENX,LENY REAL ONE,ZERO PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) REAL TEMP LOGICAL OK,LSAME OK = (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR. . LSAME(TRANS,'C')) .AND. ((M.GT.0) .AND. (N.GT.0) .AND. . (LDA.GE.M)) * * Quick return if possible. * IF (((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE)) .OR. .NOT. OK) RETURN * * Set LENX and LENY, the lengths of the vectors x and y. * IF (LSAME(TRANS,'N')) THEN LENX = N LENY = M * ELSE LENX = M LENY = N END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * * First form y := beta*y and set up the start points in X and Y if * the increments are not both unity. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN IF (BETA.NE.ONE) THEN IF (BETA.EQ.ZERO) THEN DO 10,I = 1,LENY Y(I) = ZERO 10 CONTINUE * ELSE DO 20,I = 1,LENY Y(I) = BETA*Y(I) 20 CONTINUE END IF * END IF * ELSE IF (INCX.GT.0) THEN KX = 1 * ELSE KX = 1 - (LENX-1)*INCX END IF * IF (INCY.GT.0) THEN KY = 1 * ELSE KY = 1 - (LENY-1)*INCY END IF * IF (BETA.NE.ONE) THEN IY = KY IF (BETA.EQ.ZERO) THEN DO 30,I = 1,LENY Y(IY) = ZERO IY = IY + INCY 30 CONTINUE * ELSE DO 40,I = 1,LENY Y(IY) = BETA*Y(IY) IY = IY + INCY 40 CONTINUE END IF * END IF * END IF * IF (ALPHA.EQ.ZERO) RETURN IF (LSAME(TRANS,'N')) THEN * * Form y := alpha*A*x + y. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 60,J = 1,N IF (X(J).NE.ZERO) THEN TEMP = ALPHA*X(J) DO 50,I = 1,M Y(I) = Y(I) + TEMP*A(I,J) 50 CONTINUE END IF * 60 CONTINUE * ELSE JX = KX DO 80,J = 1,N IF (X(JX).NE.ZERO) THEN TEMP = ALPHA*X(JX) IY = KY DO 70,I = 1,M Y(IY) = Y(IY) + TEMP*A(I,J) IY = IY + INCY 70 CONTINUE END IF * JX = JX + INCX 80 CONTINUE END IF * ELSE * * Form y := alpha*A'*x + y. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 100,J = 1,N TEMP = ZERO DO 90,I = 1,M TEMP = TEMP + A(I,J)*X(I) 90 CONTINUE Y(J) = Y(J) + ALPHA*TEMP 100 CONTINUE * ELSE JY = KY DO 120,J = 1,N TEMP = ZERO IX = KX DO 110,I = 1,M TEMP = TEMP + A(I,J)*X(IX) IX = IX + INCX 110 CONTINUE Y(JY) = Y(JY) + ALPHA*TEMP JY = JY + INCY 120 CONTINUE END IF * END IF * RETURN * * End of SGEMV . * END SUBROUTINE SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) CHARACTER *1 TRANS INTEGER M,N,KL,KU,LDA,INCX,INCY REAL ALPHA,A(LDA,*),X(*),BETA,Y(*) * * Purpose * ======= * * SGBMV performs one of the matrix-vector operations * * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, * * where alpha and beta are scalars, x and y are vectors and A is an * m by n band matrix, with kl sub-diagonals and ku super-diagonals. * * Parameters * ========== * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' y := alpha*A*x + beta*y. * * TRANS = 'T' y := alpha*A'*x + beta*y. * * TRANS = 'C' y := alpha*A'*x + beta*y. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * KL - INTEGER. * On entry, KL specifies the number of sub-diagonals of the * matrix A. KL must satisfy 0 .le. KL. * Unchanged on exit. * * KU - INTEGER. * On entry, KU specifies the number of super-diagonals of the * matrix A. KU must satisfy 0 .le. KU. * Unchanged on exit. * * Users may find that efficiency of their application is enhanced by * adjusting the values of m and n so that KL .ge. max(0,m-n) and * KU .ge. max(0,n-m) or KL and KU so that KL .lt. m and KU .lt. n. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry, the leading ( kl + ku + 1 ) by n part of the * array A must contain the matrix of coefficients, supplied * column by column, with the leading diagonal of the matrix in * row ( ku + 1 ) of the array, the first super-diagonal * starting at position 2 in row ku, the first sub-diagonal * starting at position 1 in row ( ku + 2 ), and so on. * This placement of the data can be realized with the * following loops: * DO 20 J =1,N * K=KU+1-J * DO 10 I =MAX(1,J-KU),MIN(M,J+KL) * A(K+I,J)=matrix entry of row I, column J. * 10 CONTINUE * 20 CONTINUE * Elements in the array A that do not correspond to elements * in the band matrix (such as the top left ku by ku triangle) * are not referenced. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the leading dimension of A as * declared in the calling (sub) program. LDA must be at least * ( kl + ku + 1 ). * Unchanged on exit. * * X - REAL array of DIMENSION at least * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' * and at least * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. * Before entry, the incremented array X must contain the * vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. * Unchanged on exit. * * BETA - REAL . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then Y need not be set on input. * Unchanged on exit. * * Y - REAL array of DIMENSION at least * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' * and at least * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. * Before entry, the incremented array Y must contain the * vector y. On exit, Y is overwritten by the updated vector y. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. * Unchanged on exit. * * * * * Level 2 Blas routine. * * -- Written on 27-Sept-1985. * Sven Hammarling, Nag Central Office. C REVISED 860623 C REVISED YYMMDD C BY R. J. HANSON, SANDIA NATIONAL LABS. * INTRINSIC MAX,MIN INTEGER I,IX,IY,J,JX,JY INTEGER K,KUP1,KX,KY,LENX,LENY REAL ONE,ZERO PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) REAL TEMP LOGICAL OK,LSAME OK = (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR. . LSAME(TRANS,'C')) .AND. (M.GT.0) .AND. (N.GT.0) .AND. . (KL.GE.0) .AND. (KU.GE.0) .AND. . (LDA.GE. (KL+KU+1)) * * Quick return if possible. * IF ( .NOT. OK .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN * * Set LENX and LENY, the lengths of the vectors x and y. * IF (LSAME(TRANS,'N')) THEN LENX = N LENY = M * ELSE LENX = M LENY = N END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through the band part of A. * * First form y := beta*y and set up the start points in X and Y * if the increments are not both unity. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN IF (BETA.NE.ONE) THEN IF (BETA.EQ.ZERO) THEN DO 10,I = 1,LENY Y(I) = ZERO 10 CONTINUE * ELSE DO 20,I = 1,LENY Y(I) = BETA*Y(I) 20 CONTINUE END IF * END IF * ELSE IF (INCX.GT.0) THEN KX = 1 * ELSE KX = 1 - (LENX-1)*INCX END IF * IF (INCY.GT.0) THEN KY = 1 * ELSE KY = 1 - (LENY-1)*INCY END IF * IF (BETA.NE.ONE) THEN IY = KY IF (BETA.EQ.ZERO) THEN DO 30,I = 1,LENY Y(IY) = ZERO IY = IY + INCY 30 CONTINUE * ELSE DO 40,I = 1,LENY Y(IY) = BETA*Y(IY) IY = IY + INCY 40 CONTINUE END IF * END IF * END IF * IF (ALPHA.EQ.ZERO) RETURN KUP1 = KU + 1 IF (LSAME(TRANS,'N')) THEN * * Form y := alpha*A*x + y. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 60,J = 1,N IF (X(J).NE.ZERO) THEN TEMP = ALPHA*X(J) K = KUP1 - J DO 50,I = MAX(1,J-KU),MIN(M,J+KL) Y(I) = Y(I) + TEMP*A(K+I,J) 50 CONTINUE END IF * 60 CONTINUE * ELSE JX = KX DO 80,J = 1,N IF (X(JX).NE.ZERO) THEN TEMP = ALPHA*X(JX) IY = KY K = KUP1 - J DO 70,I = MAX(1,J-KU),MIN(M,J+KL) Y(IY) = Y(IY) + TEMP*A(K+I,J) IY = IY + INCY 70 CONTINUE END IF * JX = JX + INCX IF (J.GT.KU) KY = KY + INCY 80 CONTINUE END IF * ELSE * * Form y := alpha*A'*x + y. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 100,J = 1,N TEMP = ZERO K = KUP1 - J DO 90,I = MAX(1,J-KU),MIN(M,J+KL) TEMP = TEMP + A(K+I,J)*X(I) 90 CONTINUE Y(J) = Y(J) + ALPHA*TEMP 100 CONTINUE * ELSE JY = KY DO 120,J = 1,N TEMP = ZERO IX = KX K = KUP1 - J DO 110,I = MAX(1,J-KU),MIN(M,J+KL) TEMP = TEMP + A(K+I,J)*X(IX) IX = IX + INCX 110 CONTINUE Y(JY) = Y(JY) + ALPHA*TEMP JY = JY + INCY IF (J.GT.KU) KX = KX + INCX 120 CONTINUE END IF * END IF * RETURN * * End of SGBMV . * END SUBROUTINE SSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) CHARACTER *1 UPLO INTEGER N,LDA,INCX,INCY REAL ALPHA,A(LDA,*),X(*),BETA,Y(*) * * Purpose * ======= * * SSYMV performs the matrix-vector operation * * y := alpha*A*x + beta*y, * * where alpha and beta are scalars, x and y are n element vectors and * A is an n by n symmetric matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array A is to be referenced as * follows: * * UPLO = 'U' Only the upper triangular part of A * is to be referenced. * * UPLO = 'L' Only the lower triangular part of A * is to be referenced. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U', the leading n by n * upper triangular part of the array A must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of A is not referenced. * Before entry with UPLO = 'L', the leading n by n * lower triangular part of the array A must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of A is not referenced. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least max(n,1). * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. * Unchanged on exit. * * BETA - REAL . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then Y need not be set on input. * Unchanged on exit. * * Y - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCY ) ). * Before entry, the incremented array Y must contain the n * element vector y. On exit, Y is overwritten by the updated * vector y. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 27-Sept-1985. * Sven Hammarling, Nag Central Office. C REVISED 860623 C REVISED YYMMDD C BY R. J. HANSON, SANDIA NATIONAL LABS. * INTEGER I,IX,IY,J,JX,JY INTEGER KX,KY REAL ONE,ZERO PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) REAL TEMP1,TEMP2 LOGICAL OK,LSAME OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0) .AND. . (LDA.GE.N) * * Quick return if possible. * IF ( .NOT. OK .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through the triangular part * of A. * * First form y := beta*y and set up the start points in X and Y if * the increments are not both unity. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN IF (BETA.NE.ONE) THEN IF (BETA.EQ.ZERO) THEN DO 10,I = 1,N Y(I) = ZERO 10 CONTINUE * ELSE DO 20,I = 1,N Y(I) = BETA*Y(I) 20 CONTINUE END IF * END IF * ELSE IF (INCX.GT.0) THEN KX = 1 * ELSE KX = 1 - (N-1)*INCX END IF * IF (INCY.GT.0) THEN KY = 1 * ELSE KY = 1 - (N-1)*INCY END IF * IF (BETA.NE.ONE) THEN IY = KY IF (BETA.EQ.ZERO) THEN DO 30,I = 1,N Y(IY) = ZERO IY = IY + INCY 30 CONTINUE * ELSE DO 40,I = 1,N Y(IY) = BETA*Y(IY) IY = IY + INCY 40 CONTINUE END IF * END IF * END IF * IF (ALPHA.EQ.ZERO) RETURN IF (LSAME(UPLO,'U')) THEN * * Form y when A is stored in upper triangle. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 60,J = 1,N TEMP1 = ALPHA*X(J) TEMP2 = ZERO DO 50,I = 1,J - 1 Y(I) = Y(I) + TEMP1*A(I,J) TEMP2 = TEMP2 + A(I,J)*X(I) 50 CONTINUE Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2 60 CONTINUE * ELSE IX = KX - INCX DO 80,J = 1,N TEMP1 = ALPHA*X(IX+INCX) TEMP2 = ZERO IX = KX IY = KY DO 70,I = 1,J - 1 Y(IY) = Y(IY) + TEMP1*A(I,J) TEMP2 = TEMP2 + A(I,J)*X(IX) IX = IX + INCX IY = IY + INCY 70 CONTINUE Y(IY) = Y(IY) + TEMP1*A(J,J) + ALPHA*TEMP2 80 CONTINUE END IF * ELSE * * Form y when A is stored in lower triangle. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 100,J = 1,N TEMP1 = ALPHA*X(J) TEMP2 = ZERO Y(J) = Y(J) + TEMP1*A(J,J) DO 90,I = J + 1,N Y(I) = Y(I) + TEMP1*A(I,J) TEMP2 = TEMP2 + A(I,J)*X(I) 90 CONTINUE Y(J) = Y(J) + ALPHA*TEMP2 100 CONTINUE * ELSE JX = KX JY = KY DO 120,J = 1,N TEMP1 = ALPHA*X(JX) TEMP2 = ZERO Y(JY) = Y(JY) + TEMP1*A(J,J) IX = JX IY = JY DO 110,I = J + 1,N IX = IX + INCX IY = IY + INCY Y(IY) = Y(IY) + TEMP1*A(I,J) TEMP2 = TEMP2 + A(I,J)*X(IX) 110 CONTINUE Y(JY) = Y(JY) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 120 CONTINUE END IF * END IF * RETURN * * End of SSYMV . * END SUBROUTINE SSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) CHARACTER *1 UPLO INTEGER N,K,LDA,INCX,INCY REAL ALPHA,A(LDA,*),X(*),BETA,Y(*) * * Purpose * ======= * * SSBMV performs the matrix-vector operation * * y := alpha*A*x + beta*y, * * where alpha and beta are scalars, x and y are n element vectors and * A is an n by n symmetric band matrix, with k super-diagonals. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the band matrix A is being supplied as * follows: * * UPLO = 'U' The upper triangular part of A is * being supplied. * * UPLO = 'L' The lower triangular part of A is * being supplied. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * K - INTEGER. * On entry, K specifies the number of super-diagonals of the * matrix A. K must satisfy 0 .le. K .lt. n. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U', the leading ( k + 1 ) * by n part of the array A must contain the upper triangular * band part of the symmetric matrix, supplied column by * column, with the leading diagonal of the matrix in row * ( k + 1 ) of the array, the first super-diagonal starting at * position 2 in row k, and so on. The top left k by k triangle * of the array A is not referenced. * Before entry with UPLO = 'L', the leading ( k + 1 ) * by n part of the array A must contain the lower triangular * band part of the symmetric matrix, supplied column by * column, with the leading diagonal of the matrix in row 1 of * the array, the first sub-diagonal starting at position 1 in * row 2, and so on. The bottom right k by k triangle of the * array A is not referenced. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the leading dimension of A as * declared in the calling (sub) program. LDA must be at least * ( k + 1 ). * Unchanged on exit. * * X - REAL array of DIMENSION at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the * vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. * Unchanged on exit. * * BETA - REAL . * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * Y - REAL array of DIMENSION at least * ( 1 + ( n - 1 )*abs( INCY ) ). * Before entry, the incremented array Y must contain the * vector y. On exit, Y is overwritten by the updated vector y. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. * Unchanged on exit. * * * * Level 2 Blas routine. * * -- Written on 30-September-1985. * Sven Hammarling, Nag Central Office. C REVISED 860623 C REVISED YYMMDD C BY R. J. HANSON, SANDIA NATIONAL LABS. * INTRINSIC MAX,MIN INTEGER I,IX,IY,J,JX,JY INTEGER KPLUS1,KX,KY,L REAL ONE,ZERO PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) REAL TEMP1,TEMP2 LOGICAL OK,LSAME OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0) .AND. . (K.GE.0) .AND. (K.LT.N) .AND. (LDA.GE. (K+1)) * * Quick return if possible. * IF ( .NOT. OK .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN * * Start the operations. In this version the elements of the array A * are accessed sequentially with one pass through A. * * First form y := beta*y and set up the start points in X and Y if * the increments are not both unity. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN IF (BETA.NE.ONE) THEN IF (BETA.EQ.ZERO) THEN DO 10,I = 1,N Y(I) = ZERO 10 CONTINUE * ELSE DO 20,I = 1,N Y(I) = BETA*Y(I) 20 CONTINUE END IF * END IF * ELSE IF (INCX.GT.0) THEN KX = 1 * ELSE KX = 1 - (N-1)*INCX END IF * IF (INCY.GT.0) THEN KY = 1 * ELSE KY = 1 - (N-1)*INCY END IF * IF (BETA.NE.ONE) THEN IY = KY IF (BETA.EQ.ZERO) THEN DO 30,I = 1,N Y(IY) = ZERO IY = IY + INCY 30 CONTINUE * ELSE DO 40,I = 1,N Y(IY) = BETA*Y(IY) IY = IY + INCY 40 CONTINUE END IF * END IF * END IF * IF (ALPHA.EQ.ZERO) RETURN IF (LSAME(UPLO,'U')) THEN * * Form y when upper triangle of A is stored. * KPLUS1 = K + 1 IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 60,J = 1,N TEMP1 = ALPHA*X(J) TEMP2 = ZERO I = MAX(1,J-K) DO 50,L = KPLUS1 + I - J,K Y(I) = Y(I) + TEMP1*A(L,J) TEMP2 = TEMP2 + A(L,J)*X(I) I = I + 1 50 CONTINUE Y(J) = Y(J) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2 60 CONTINUE * ELSE IX = KX - INCX DO 80,J = 1,N TEMP1 = ALPHA*X(IX+INCX) TEMP2 = ZERO IX = KX IY = KY DO 70,L = 1 + MAX(KPLUS1-J,0),K Y(IY) = Y(IY) + TEMP1*A(L,J) TEMP2 = TEMP2 + A(L,J)*X(IX) IX = IX + INCX IY = IY + INCY 70 CONTINUE Y(IY) = Y(IY) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2 IF (J.GT.K) THEN KX = KX + INCX KY = KY + INCY END IF * 80 CONTINUE END IF * ELSE * * Form y when lower triangle of A is stored. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 100,J = 1,N TEMP1 = ALPHA*X(J) TEMP2 = ZERO Y(J) = Y(J) + TEMP1*A(1,J) I = J + 1 DO 90,L = 2,1 + MIN(K,N-J) Y(I) = Y(I) + TEMP1*A(L,J) TEMP2 = TEMP2 + A(L,J)*X(I) I = I + 1 90 CONTINUE Y(J) = Y(J) + ALPHA*TEMP2 100 CONTINUE * ELSE JX = KX JY = KY DO 120,J = 1,N TEMP1 = ALPHA*X(JX) TEMP2 = ZERO Y(JY) = Y(JY) + TEMP1*A(1,J) IX = JX IY = JY DO 110,L = 2,1 + MIN(K,N-J) IX = IX + INCX IY = IY + INCY Y(IY) = Y(IY) + TEMP1*A(L,J) TEMP2 = TEMP2 + A(L,J)*X(IX) 110 CONTINUE Y(JY) = Y(JY) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 120 CONTINUE END IF * END IF * RETURN * * End of SSBMV . * END SUBROUTINE SSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) CHARACTER *1 UPLO INTEGER N,INCX,INCY REAL ALPHA,AP(*),X(*),BETA,Y(*) * * Purpose * ======= * * SSPMV performs the matrix-vector operation * * y := alpha*A*x + beta*y, * * where alpha and beta are scalars, x and y are n element vectors and * A is an n by n symmetric matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the matrix A is supplied in the packed * array AP as follows: * * UPLO = 'U' The upper triangular part of A is * supplied in AP. * * UPLO = 'L' The lower triangular part of A is * supplied in AP. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * AP - REAL array of DIMENSION at least * ( ( n*( n + 1 ) )/2 ). * Before entry with UPLO = 'U', the array AP must * contain the upper triangular part of the symmetric matrix * packed sequentially, column by column, so that AP( 1 ) * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) * and a( 2, 2 ) respectively, and so on. * Before entry with UPLO = 'L', the array AP must * contain the lower triangular part of the symmetric matrix * packed sequentially, column by column, so that AP( 1 ) * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) * and a( 3, 1 ) respectively, and so on. * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. * Unchanged on exit. * * BETA - REAL . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then Y need not be set on input. * Unchanged on exit. * * Y - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCY ) ). * Before entry, the incremented array Y must contain the n * element vector y. On exit, Y is overwritten by the updated * vector y. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. * Unchanged on exit. * * * * * * Level 2 Blas routine. * * -- Written on 27-Sept-1985. * Sven Hammarling, Nag Central Office. C REVISED 860623 C REVISED YYMMDD C BY R. J. HANSON, SANDIA NATIONAL LABS. * INTEGER I,IX,IY,J,JX,JY INTEGER K,KK,KX,KY REAL ONE,ZERO PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) REAL TEMP1,TEMP2 LOGICAL OK,LSAME OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0) * * Quick return if possible. * IF ( .NOT. OK .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN * * Start the operations. In this version the elements of the array AP * are accessed sequentially with one pass through AP. * * First form y := beta*y and set up the start points in X and Y if * the increments are not both unity. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN IF (BETA.NE.ONE) THEN IF (BETA.EQ.ZERO) THEN DO 10,I = 1,N Y(I) = ZERO 10 CONTINUE * ELSE DO 20,I = 1,N Y(I) = BETA*Y(I) 20 CONTINUE END IF * END IF * ELSE IF (INCX.GT.0) THEN KX = 1 * ELSE KX = 1 - (N-1)*INCX END IF * IF (INCY.GT.0) THEN KY = 1 * ELSE KY = 1 - (N-1)*INCY END IF * IF (BETA.NE.ONE) THEN IY = KY IF (BETA.EQ.ZERO) THEN DO 30,I = 1,N Y(IY) = ZERO IY = IY + INCY 30 CONTINUE * ELSE DO 40,I = 1,N Y(IY) = BETA*Y(IY) IY = IY + INCY 40 CONTINUE END IF * END IF * END IF * IF (ALPHA.EQ.ZERO) RETURN K = 1 IF (LSAME(UPLO,'U')) THEN * * Form y when AP contains the upper triangle. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 60,J = 1,N TEMP1 = ALPHA*X(J) TEMP2 = ZERO DO 50,I = 1,J - 1 Y(I) = Y(I) + TEMP1*AP(K) TEMP2 = TEMP2 + AP(K)*X(I) K = K + 1 50 CONTINUE Y(J) = Y(J) + TEMP1*AP(K) + ALPHA*TEMP2 K = K + 1 60 CONTINUE * ELSE IX = KX - INCX DO 80,J = 1,N TEMP1 = ALPHA*X(IX+INCX) TEMP2 = ZERO IX = KX IY = KY KK = K DO 70,K = KK,KK + J - 2 Y(IY) = Y(IY) + TEMP1*AP(K) TEMP2 = TEMP2 + AP(K)*X(IX) IX = IX + INCX IY = IY + INCY 70 CONTINUE Y(IY) = Y(IY) + TEMP1*AP(K) + ALPHA*TEMP2 K = K + 1 80 CONTINUE END IF * ELSE * * Form y when AP contains the upper triangle. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 100,J = 1,N TEMP1 = ALPHA*X(J) TEMP2 = ZERO Y(J) = Y(J) + TEMP1*AP(K) K = K + 1 DO 90,I = J + 1,N Y(I) = Y(I) + TEMP1*AP(K) TEMP2 = TEMP2 + AP(K)*X(I) K = K + 1 90 CONTINUE Y(J) = Y(J) + ALPHA*TEMP2 100 CONTINUE * ELSE JX = KX JY = KY DO 120,J = 1,N TEMP1 = ALPHA*X(JX) TEMP2 = ZERO Y(JY) = Y(JY) + TEMP1*AP(K) IX = JX IY = JY KK = K + 1 DO 110,K = KK,KK + N - (J+1) IX = IX + INCX IY = IY + INCY Y(IY) = Y(IY) + TEMP1*AP(K) TEMP2 = TEMP2 + AP(K)*X(IX) 110 CONTINUE Y(JY) = Y(JY) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 120 CONTINUE END IF * END IF * RETURN * * End of SSPMV . * END SUBROUTINE STRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) CHARACTER *1 UPLO,TRANS,DIAG INTEGER N,LDA,INCX REAL A(LDA,*),X(*) * * Purpose * ======= * * STRMV performs one of the matrix-vector operations * * x := A*x, or x := A'*x, * * where x is n element vector and A is an n by n unit, or non-unit, * upper or lower triangular matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' A is an upper triangular matrix. * * UPLO = 'L' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' x := A*x. * * TRANS = 'T' x := A'*x. * * TRANS = 'C' x := A'*x. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' A is assumed to be unit triangular. * * DIAG = 'N' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U', the leading n by n * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L', the leading n by n * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least max(n,1). * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. On exit, X is overwritten with the * tranformed vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. * Unchanged on exit. * * * * * Level 2 Blas routine. * * -- Written on 30-September-1985. * Sven Hammarling, Nag Central Office. C REVISED 860623 C REVISED YYMMDD C BY R. J. HANSON, SANDIA NATIONAL LABS. * LOGICAL NOUNIT INTEGER I,IX,J,JX,KX REAL ZERO PARAMETER (ZERO=0.0E+0) LOGICAL OK,LSAME OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. . (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR. . LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR. . LSAME(DIAG,'N')) .AND. (N.GT.0) .AND. (LDA.GE.N) * * * Quick return if possible. * IF ( .NOT. OK) RETURN NOUNIT = LSAME(DIAG,'N') * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF (INCX.LE.0) THEN KX = 1 - (N-1)*INCX * ELSE IF (INCX.NE.1) THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF (LSAME(TRANS,'N')) THEN * * Form x := A*x. * IF (LSAME(UPLO,'U')) THEN IF (INCX.EQ.1) THEN DO 20,J = 1,N IF (X(J).NE.ZERO) THEN DO 10,I = 1,J - 1 X(I) = X(I) + X(J)*A(I,J) 10 CONTINUE IF (NOUNIT) X(J) = X(J)*A(J,J) END IF * 20 CONTINUE * ELSE JX = KX DO 40,J = 1,N IF (X(JX).NE.ZERO) THEN IX = KX DO 30,I = 1,J - 1 X(IX) = X(IX) + X(JX)*A(I,J) IX = IX + INCX 30 CONTINUE IF (NOUNIT) X(JX) = X(JX)*A(J,J) END IF * JX = JX + INCX 40 CONTINUE END IF * ELSE IF (INCX.EQ.1) THEN DO 60,J = N,1,-1 IF (X(J).NE.ZERO) THEN DO 50,I = N,J + 1,-1 X(I) = X(I) + X(J)*A(I,J) 50 CONTINUE IF (NOUNIT) X(J) = X(J)*A(J,J) END IF * 60 CONTINUE * ELSE KX = KX + (N-1)*INCX JX = KX DO 80,J = N,1,-1 IF (X(JX).NE.ZERO) THEN IX = KX DO 70,I = N,J + 1,-1 X(IX) = X(IX) + X(JX)*A(I,J) IX = IX - INCX 70 CONTINUE IF (NOUNIT) X(JX) = X(JX)*A(J,J) END IF * JX = JX - INCX 80 CONTINUE END IF * END IF * ELSE * * Form x := A'*x. * IF (LSAME(UPLO,'U')) THEN IF (INCX.EQ.1) THEN DO 100,J = N,1,-1 IF (NOUNIT) X(J) = X(J)*A(J,J) DO 90,I = J - 1,1,-1 X(J) = X(J) + A(I,J)*X(I) 90 CONTINUE 100 CONTINUE * ELSE JX = KX + (N-1)*INCX DO 120,J = N,1,-1 IX = JX IF (NOUNIT) X(JX) = X(JX)*A(J,J) DO 110,I = J - 1,1,-1 IX = IX - INCX X(JX) = X(JX) + A(I,J)*X(IX) 110 CONTINUE JX = JX - INCX 120 CONTINUE END IF * ELSE IF (INCX.EQ.1) THEN DO 140,J = 1,N IF (NOUNIT) X(J) = X(J)*A(J,J) DO 130,I = J + 1,N X(J) = X(J) + A(I,J)*X(I) 130 CONTINUE 140 CONTINUE * ELSE JX = KX DO 160,J = 1,N IX = JX IF (NOUNIT) X(JX) = X(JX)*A(J,J) DO 150,I = J + 1,N IX = IX + INCX X(JX) = X(JX) + A(I,J)*X(IX) 150 CONTINUE JX = JX + INCX 160 CONTINUE END IF * END IF * END IF * RETURN * * End of STRMV . * END SUBROUTINE STBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) CHARACTER *1 UPLO,TRANS,DIAG INTEGER N,K,LDA,INCX REAL A(LDA,*),X(*) * * Purpose * ======= * * STBMV performs one of the matrix-vector operations * * x := A*x, or x := A'*x, * * where x is n element vector and A is an n by n unit, or non-unit, * upper or lower triangular band matrix, with ( k + 1 ) diagonals. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' A is an upper triangular matrix. * * UPLO = 'L' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' x := A*x. * * TRANS = 'T' x := A'*x. * * TRANS = 'C' x := A'*x. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' A is assumed to be unit triangular. * * DIAG = 'N' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with UPLO = 'U', K specifies the number of * super-diagonals of the matrix A. * On entry with UPLO = 'L', K specifies the number of * sub-diagonals of the matrix A. * K must satisfy 0 .le. K. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U', the leading ( k + 1 ) * by n part of the array A must contain the upper triangular * band part of the matrix of coefficients, supplied column by * column, with the leading diagonal of the matrix in row * ( k + 1 ) of the array, the first super-diagonal starting at * position 2 in row k, and so on. The top left k by k triangle * of the array A is not referenced. * Before entry with UPLO = 'L', the leading ( k + 1 ) * by n part of the array A must contain the lower triangular * band part of the matrix of coefficients, supplied column by * column, with the leading diagonal of the matrix in row 1 of * the array, the first sub-diagonal starting at position 1 in * row 2, and so on. The bottom right k by k triangle of the * array A is not referenced. * Note that when DIAG = 'U' the elements of the array A * corresponding to the diagonal elements of the matrix are not * referenced, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the leading dimension of A as * declared in the calling (sub) program. LDA must be at least * ( k + 1 ). * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. On exit, X is overwritten with the * tranformed vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. * Unchanged on exit. * * * * * Level 2 Blas routine. * * -- Written on 5-November-1985. * Sven Hammarling, Nag Central Office. C REVISED 860623 C REVISED YYMMDD C BY R. J. HANSON, SANDIA NATIONAL LABS. * INTRINSIC MAX,MIN LOGICAL NOUNIT INTEGER I,IX,J,JX,KPLUS1,KX INTEGER L REAL ZERO PARAMETER (ZERO=0.0E+0) LOGICAL OK,LSAME OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. . (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR. . LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR. . LSAME(DIAG,'N')) .AND. (N.GT.0) .AND. (K.GE.0) .AND. . (LDA.GE. (K+1)) * * * Quick return if possible. * IF ( .NOT. OK) RETURN NOUNIT = LSAME(DIAG,'N') * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF (INCX.LE.0) THEN KX = 1 - (N-1)*INCX * ELSE IF (INCX.NE.1) THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF (LSAME(TRANS,'N')) THEN * * Form x := A*x. * IF (LSAME(UPLO,'U')) THEN KPLUS1 = K + 1 IF (INCX.EQ.1) THEN DO 20,J = 1,N IF (X(J).NE.ZERO) THEN I = MAX(1,J-K) DO 10,L = KPLUS1 + I - J,K X(I) = X(I) + X(J)*A(L,J) I = I + 1 10 CONTINUE IF (NOUNIT) X(J) = X(J)*A(KPLUS1,J) END IF * 20 CONTINUE * ELSE JX = KX DO 40,J = 1,N IF (X(JX).NE.ZERO) THEN IX = KX DO 30,L = 1 + MAX(KPLUS1-J,0),K X(IX) = X(IX) + X(JX)*A(L,J) IX = IX + INCX 30 CONTINUE IF (NOUNIT) X(JX) = X(JX)*A(KPLUS1,J) END IF * JX = JX + INCX IF (J.GT.K) KX = KX + INCX 40 CONTINUE END IF * ELSE IF (INCX.EQ.1) THEN DO 60,J = N,1,-1 IF (X(J).NE.ZERO) THEN I = MIN(N,J+K) DO 50,L = 1 + I - J,2,-1 X(I) = X(I) + X(J)*A(L,J) I = I - 1 50 CONTINUE IF (NOUNIT) X(J) = X(J)*A(1,J) END IF * 60 CONTINUE * ELSE KX = KX + (N-1)*INCX JX = KX DO 80,J = N,1,-1 IF (X(JX).NE.ZERO) THEN IX = KX DO 70,L = 1 + MIN(K,N-J),2,-1 X(IX) = X(IX) + X(JX)*A(L,J) IX = IX - INCX 70 CONTINUE IF (NOUNIT) X(JX) = X(JX)*A(1,J) END IF * JX = JX - INCX IF ((N-J).GE.K) KX = KX - INCX 80 CONTINUE END IF * END IF * ELSE * * Form x := A'*x. * IF (LSAME(UPLO,'U')) THEN KPLUS1 = K + 1 IF (INCX.EQ.1) THEN DO 100,J = N,1,-1 I = J IF (NOUNIT) X(J) = X(J)*A(KPLUS1,J) DO 90,L = K,1 + MAX(KPLUS1-J,0),-1 I = I - 1 X(J) = X(J) + A(L,J)*X(I) 90 CONTINUE 100 CONTINUE * ELSE KX = KX + (N-1)*INCX JX = KX DO 120,J = N,1,-1 KX = KX - INCX IX = KX IF (NOUNIT) X(JX) = X(JX)*A(KPLUS1,J) DO 110,L = K,1 + MAX(KPLUS1-J,0),-1 X(JX) = X(JX) + A(L,J)*X(IX) IX = IX - INCX 110 CONTINUE JX = JX - INCX 120 CONTINUE END IF * ELSE IF (INCX.EQ.1) THEN DO 140,J = 1,N I = J IF (NOUNIT) X(J) = X(J)*A(1,J) DO 130,L = 2,1 + MIN(K,N-J) I = I + 1 X(J) = X(J) + A(L,J)*X(I) 130 CONTINUE 140 CONTINUE * ELSE JX = KX DO 160,J = 1,N KX = KX + INCX IX = KX IF (NOUNIT) X(JX) = X(JX)*A(1,J) DO 150,L = 2,1 + MIN(K,N-J) X(JX) = X(JX) + A(L,J)*X(IX) IX = IX + INCX 150 CONTINUE JX = JX + INCX 160 CONTINUE END IF * END IF * END IF * RETURN * * End of STBMV . * END SUBROUTINE STPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) CHARACTER *1 UPLO,TRANS,DIAG INTEGER N,INCX REAL AP(*),X(*) * * Purpose * ======= * * STPMV performs one of the matrix-vector operations * * x := A*x, or x := A'*x, * * where x is n element vector and A is an n by n unit, or non-unit, * upper or lower triangular matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' A is an upper triangular matrix. * * UPLO = 'L' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' x := A*x. * * TRANS = 'T' x := A'*x. * * TRANS = 'C' x := A'*x. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' A is assumed to be unit triangular. * * DIAG = 'N' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * AP - REAL array of DIMENSION at least * ( ( n*( n + 1 ) )/2 ). * Before entry with UPLO = 'U', the array AP must * contain the upper triangular matrix packed sequentially, * column by column, so that AP( 1 ) contains a( 1, 1 ), * AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) * respectively, and so on. * Before entry with UPLO = 'L', the array AP must * contain the lower triangular matrix packed sequentially, * column by column, so that AP( 1 ) contains a( 1, 1 ), * AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) * respectively, and so on. * Note that when DIAG = 'U', the diagonal elements of * A are not referenced, but are assumed to be unity. * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. On exit, X is overwritten with the * tranformed vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. * Unchanged on exit. * * * Note that UPLO, TRANS, DIAG and N must be such that the value of the * LOGICAL variable OK in the following statement is true. * * * * Level 2 Blas routine. * * -- Written on 2-October-1985. * Sven Hammarling, Nag Central Office. C REVISED 860623 C REVISED YYMMDD C BY R. J. HANSON, SANDIA NATIONAL LABS. * LOGICAL NOUNIT INTEGER I,IX,J,JX,K,KK INTEGER KX REAL ZERO PARAMETER (ZERO=0.0E+0) LOGICAL OK,LSAME OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. . (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR. . LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR. . LSAME(DIAG,'N')) .AND. (N.GT.0) * * * Quick return if possible. * IF ( .NOT. OK) RETURN NOUNIT = LSAME(DIAG,'N') * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF (INCX.LE.0) THEN KX = 1 - (N-1)*INCX * ELSE IF (INCX.NE.1) THEN KX = 1 END IF * * Start the operations. In this version the elements of AP are * accessed sequentially with one pass through AP. * IF (LSAME(TRANS,'N')) THEN * * Form x:= A*x. * IF (LSAME(UPLO,'U')) THEN K = 1 IF (INCX.EQ.1) THEN DO 20,J = 1,N IF (X(J).NE.ZERO) THEN DO 10,I = 1,J - 1 X(I) = X(I) + X(J)*AP(K) K = K + 1 10 CONTINUE IF (NOUNIT) X(J) = X(J)*AP(K) K = K + 1 * ELSE K = K + J END IF * 20 CONTINUE * ELSE JX = KX DO 40,J = 1,N IF (X(JX).NE.ZERO) THEN IX = KX KK = K DO 30,K = KK,KK + J - 2 X(IX) = X(IX) + X(JX)*AP(K) IX = IX + INCX 30 CONTINUE IF (NOUNIT) X(JX) = X(JX)*AP(K) K = K + 1 * ELSE K = K + J END IF * JX = JX + INCX 40 CONTINUE END IF * ELSE K = (N* (N+1))/2 IF (INCX.EQ.1) THEN DO 60,J = N,1,-1 IF (X(J).NE.ZERO) THEN DO 50,I = N,J + 1,-1 X(I) = X(I) + X(J)*AP(K) K = K - 1 50 CONTINUE IF (NOUNIT) X(J) = X(J)*AP(K) K = K - 1 * ELSE K = K - (N-J+1) END IF * 60 CONTINUE * ELSE KX = KX + (N-1)*INCX JX = KX DO 80,J = N,1,-1 IF (X(JX).NE.ZERO) THEN IX = KX KK = K DO 70,K = KK,KK - (N- (J+1)),-1 X(IX) = X(IX) + X(JX)*AP(K) IX = IX - INCX 70 CONTINUE IF (NOUNIT) X(JX) = X(JX)*AP(K) K = K - 1 * ELSE K = K - (N-J+1) END IF * JX = JX - INCX 80 CONTINUE END IF * END IF * ELSE * * Form x := A'*x. * IF (LSAME(UPLO,'U')) THEN K = (N* (N+1))/2 IF (INCX.EQ.1) THEN DO 100,J = N,1,-1 IF (NOUNIT) X(J) = X(J)*AP(K) K = K - 1 DO 90,I = J - 1,1,-1 X(J) = X(J) + AP(K)*X(I) K = K - 1 90 CONTINUE 100 CONTINUE * ELSE JX = KX + (N-1)*INCX DO 120,J = N,1,-1 IX = JX IF (NOUNIT) X(JX) = X(JX)*AP(K) KK = K - 1 DO 110,K = KK,KK - J + 2,-1 IX = IX - INCX X(JX) = X(JX) + AP(K)*X(IX) 110 CONTINUE JX = JX - INCX 120 CONTINUE END IF * ELSE K = 1 IF (INCX.EQ.1) THEN DO 140,J = 1,N IF (NOUNIT) X(J) = X(J)*AP(K) K = K + 1 DO 130,I = J + 1,N X(J) = X(J) + AP(K)*X(I) K = K + 1 130 CONTINUE 140 CONTINUE * ELSE JX = KX DO 160,J = 1,N IX = JX IF (NOUNIT) X(JX) = X(JX)*AP(K) KK = K + 1 DO 150,K = KK,KK + N - (J+1) IX = IX + INCX X(JX) = X(JX) + AP(K)*X(IX) 150 CONTINUE JX = JX + INCX 160 CONTINUE END IF * END IF * END IF * RETURN * * End of STPMV . * END SUBROUTINE STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) CHARACTER *1 UPLO,TRANS,DIAG INTEGER N,LDA,INCX REAL A(LDA,*),X(*) * * Purpose * ======= * * STRSV solves one of the systems of equations * * A*x = b, or A'*x = b, * * where b and x are n element vectors and A is an n by n unit, or * non-unit, upper or lower triangular matrix. * * No test for singularity or near-singularity is included in this * routine. Such tests must be performed before calling this routine. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' A is an upper triangular matrix. * * UPLO = 'L' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the equations to be solved as * follows: * * TRANS = 'N' A*x = b. * * TRANS = 'T' A'*x = b. * * TRANS = 'C' A'*x = b. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' A is assumed to be unit triangular. * * DIAG = 'N' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U', the leading n by n * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L', the leading n by n * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least max(n,1). * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element right-hand side vector b. On exit, X is overwritten * with the solution vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. * Unchanged on exit. * * * * * Level 2 Blas routine. * * -- Written on 30-September-1985. * Sven Hammarling, Nag Central Office. C REVISED 860623 C REVISED YYMMDD C BY R. J. HANSON, SANDIA NATIONAL LABS. * LOGICAL NOUNIT INTEGER I,IX,J,JX,KX REAL ZERO PARAMETER (ZERO=0.0E+0) LOGICAL OK,LSAME OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. . (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR. . LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR. . LSAME(DIAG,'N')) .AND. (N.GT.0) .AND. (LDA.GE.N) * * * Quick return if possible. * IF ( .NOT. OK) RETURN NOUNIT = LSAME(DIAG,'N') * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF (INCX.LE.0) THEN KX = 1 - (N-1)*INCX * ELSE IF (INCX.NE.1) THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF (LSAME(TRANS,'N')) THEN * * Form x := inv( A )*x. * IF (LSAME(UPLO,'U')) THEN IF (INCX.EQ.1) THEN DO 20,J = N,1,-1 IF (X(J).NE.ZERO) THEN IF (NOUNIT) X(J) = X(J)/A(J,J) DO 10,I = J - 1,1,-1 X(I) = X(I) - X(J)*A(I,J) 10 CONTINUE END IF * 20 CONTINUE * ELSE JX = KX + (N-1)*INCX DO 40,J = N,1,-1 IF (X(JX).NE.ZERO) THEN IF (NOUNIT) X(JX) = X(JX)/A(J,J) IX = JX DO 30,I = J - 1,1,-1 IX = IX - INCX X(IX) = X(IX) - X(JX)*A(I,J) 30 CONTINUE END IF * JX = JX - INCX 40 CONTINUE END IF * ELSE IF (INCX.EQ.1) THEN DO 60,J = 1,N IF (X(J).NE.ZERO) THEN IF (NOUNIT) X(J) = X(J)/A(J,J) DO 50,I = J + 1,N X(I) = X(I) - X(J)*A(I,J) 50 CONTINUE END IF * 60 CONTINUE * ELSE JX = KX DO 80,J = 1,N IF (X(JX).NE.ZERO) THEN IF (NOUNIT) X(JX) = X(JX)/A(J,J) IX = JX DO 70,I = J + 1,N IX = IX + INCX X(IX) = X(IX) - X(JX)*A(I,J) 70 CONTINUE END IF * JX = JX + INCX 80 CONTINUE END IF * END IF * ELSE * * Form x := inv( A' )*x. * IF (LSAME(UPLO,'U')) THEN IF (INCX.EQ.1) THEN DO 100,J = 1,N DO 90,I = 1,J - 1 X(J) = X(J) - A(I,J)*X(I) 90 CONTINUE IF (NOUNIT) X(J) = X(J)/A(J,J) 100 CONTINUE * ELSE JX = KX DO 120,J = 1,N IX = KX DO 110,I = 1,J - 1 X(JX) = X(JX) - A(I,J)*X(IX) IX = IX + INCX 110 CONTINUE IF (NOUNIT) X(JX) = X(JX)/A(J,J) JX = JX + INCX 120 CONTINUE END IF * ELSE IF (INCX.EQ.1) THEN DO 140,J = N,1,-1 DO 130,I = N,J + 1,-1 X(J) = X(J) - A(I,J)*X(I) 130 CONTINUE IF (NOUNIT) X(J) = X(J)/A(J,J) 140 CONTINUE * ELSE KX = KX + (N-1)*INCX JX = KX DO 160,J = N,1,-1 IX = KX DO 150,I = N,J + 1,-1 X(JX) = X(JX) - A(I,J)*X(IX) IX = IX - INCX 150 CONTINUE IF (NOUNIT) X(JX) = X(JX)/A(J,J) JX = JX - INCX 160 CONTINUE END IF * END IF * END IF * RETURN * * End of STRSV . * END SUBROUTINE STBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) CHARACTER *1 UPLO,TRANS,DIAG INTEGER N,K,LDA,INCX REAL A(LDA,*),X(*) * * Purpose * ======= * * STBSV solves one of the systems of equations * * A*x = b, or A'*x = b, * * where b and x are n element vectors and A is an n by n unit, or * non-unit, upper or lower triangular band matrix, with ( k + 1 ) * diagonals. * * No test for singularity or near-singularity is included in this * routine. Such tests must be performed before calling this routine. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' A is an upper triangular matrix. * * UPLO = 'L' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the equations to be solved as * follows: * * TRANS = 'N' A*x = b. * * TRANS = 'T' A'*x = b. * * TRANS = 'C' A'*x = b. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' A is assumed to be unit triangular. * * DIAG = 'N' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with UPLO = 'U', K specifies the number of * super-diagonals of the matrix A. * On entry with UPLO = 'L', K specifies the number of * sub-diagonals of the matrix A. * K must satisfy 0 .le. K. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U', the leading ( k + 1 ) * by n part of the array A must contain the upper triangular * band part of the matrix of coefficients, supplied column by * column, with the leading diagonal of the matrix in row * ( k + 1 ) of the array, the first super-diagonal starting at * position 2 in row k, and so on. The top left k by k triangle * of the array A is not referenced. * Before entry with UPLO = 'L', the leading ( k + 1 ) * by n part of the array A must contain the lower triangular * band part of the matrix of coefficients, supplied column by * column, with the leading diagonal of the matrix in row 1 of * the array, the first sub-diagonal starting at position 1 in * row 2, and so on. The bottom right k by k triangle of the * array A is not referenced. * Note that when DIAG = 'U' the elements of the array A * corresponding to the diagonal elements of the matrix are not * referenced, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the leading dimension of A as * declared in the calling (sub) program. LDA must be at least * ( k + 1 ). * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element right-hand side vector b. On exit, X is overwritten * with the solution vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. * Unchanged on exit. * * * * * * Level 2 Blas routine. * * -- Written on 7-November-1985. * Sven Hammarling, Nag Central Office. C REVISED 860623 C REVISED YYMMDD C BY R. J. HANSON, SANDIA NATIONAL LABS. * INTRINSIC MAX,MIN LOGICAL NOUNIT INTEGER I,IX,J,JX,KPLUS1,KX INTEGER L REAL ZERO PARAMETER (ZERO=0.0E+0) LOGICAL OK,LSAME OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. . (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR. . LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR. . LSAME(DIAG,'N')) .AND. (N.GT.0) .AND. (K.GE.0) .AND. . (LDA.GE. (K+1)) * * * Quick return if possible. * IF ( .NOT. OK) RETURN NOUNIT = LSAME(DIAG,'N') * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF (INCX.LE.0) THEN KX = 1 - (N-1)*INCX * ELSE IF (INCX.NE.1) THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed by sequentially with one pass through A. * IF (LSAME(TRANS,'N')) THEN * * Form x := inv( A )*x. * IF (LSAME(UPLO,'U')) THEN KPLUS1 = K + 1 IF (INCX.EQ.1) THEN DO 20,J = N,1,-1 IF (X(J).NE.ZERO) THEN IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J) I = J DO 10,L = K,1 + MAX(KPLUS1-J,0),-1 I = I - 1 X(I) = X(I) - X(J)*A(L,J) 10 CONTINUE END IF * 20 CONTINUE * ELSE KX = KX + (N-1)*INCX JX = KX DO 40,J = N,1,-1 KX = KX - INCX IX = KX IF (X(JX).NE.ZERO) THEN IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J) DO 30 L = K,1 + MAX(KPLUS1-J,0),-1 X(IX) = X(IX) - X(JX)*A(L,J) IX = IX - INCX 30 CONTINUE END IF * JX = JX - INCX 40 CONTINUE END IF * ELSE IF (INCX.EQ.1) THEN DO 60,J = 1,N IF (X(J).NE.ZERO) THEN IF (NOUNIT) X(J) = X(J)/A(1,J) I = J DO 50,L = 2,1 + MIN(K,N-J) I = I + 1 X(I) = X(I) - X(J)*A(L,J) 50 CONTINUE END IF * 60 CONTINUE * ELSE JX = KX DO 80,J = 1,N KX = KX + INCX IF (X(JX).NE.ZERO) THEN IF (NOUNIT) X(JX) = X(JX)/A(1,J) IX = KX DO 70,L = 2,1 + MIN(K,N-J) X(IX) = X(IX) - X(JX)*A(L,J) IX = IX + INCX 70 CONTINUE END IF * JX = JX + INCX 80 CONTINUE END IF * END IF * ELSE * * Form x := inv( A')*x. * IF (LSAME(UPLO,'U')) THEN KPLUS1 = K + 1 IF (INCX.EQ.1) THEN DO 100,J = 1,N I = MAX(1,J-K) DO 90,L = KPLUS1 + I - J,K X(J) = X(J) - A(L,J)*X(I) I = I + 1 90 CONTINUE IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J) 100 CONTINUE * ELSE JX = KX DO 120,J = 1,N IX = KX DO 110,L = 1 + MAX(KPLUS1-J,0),K X(JX) = X(JX) - A(L,J)*X(IX) IX = IX + INCX 110 CONTINUE IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J) JX = JX + INCX IF (J.GT.K) KX = KX + INCX 120 CONTINUE END IF * ELSE IF (INCX.EQ.1) THEN DO 140,J = N,1,-1 I = MIN(N,J+K) DO 130,L = 1 + I - J,2,-1 X(J) = X(J) - A(L,J)*X(I) I = I - 1 130 CONTINUE IF (NOUNIT) X(J) = X(J)/A(1,J) 140 CONTINUE * ELSE KX = KX + (N-1)*INCX JX = KX DO 160,J = N,1,-1 IX = KX DO 150,L = 1 + MIN(K,N-J),2,-1 X(JX) = X(JX) - A(L,J)*X(IX) IX = IX - INCX 150 CONTINUE IF (NOUNIT) X(JX) = X(JX)/A(1,J) JX = JX - INCX IF ((N-J).GE.K) KX = KX - INCX 160 CONTINUE END IF * END IF * END IF * RETURN * * End of STBSV . * END SUBROUTINE STPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) CHARACTER *1 UPLO,TRANS,DIAG INTEGER N,INCX REAL AP(*),X(*) * * Purpose * ======= * * STPSV solves one of the systems of equations * * A*x = b, or A'*x = b, * * where b and x are n element vectors and A is an n by n unit, or * non-unit, upper or lower triangular matrix. * * No test for singularity or near-singularity is included in this * routine. Such tests must be performed before calling this routine. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' A is an upper triangular matrix. * * UPLO = 'L' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the equations to be solved as * follows: * * TRANS = 'N' A*x = b. * * TRANS = 'T' A'*x = b. * * TRANS = 'C' A'*x = b. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' A is assumed to be unit triangular. * * DIAG = 'N' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * AP - REAL array of DIMENSION at least * ( ( n*( n + 1 ) )/2 ). * Before entry with UPLO = 'U', the array AP must * contain the upper triangular matrix packed sequentially, * column by column, so that AP( 1 ) contains a( 1, 1 ), * AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) * respectively, and so on. * Before entry with UPLO = 'L', the array AP must * contain the lower triangular matrix packed sequentially, * column by column, so that AP( 1 ) contains a( 1, 1 ), * AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) * respectively, and so on. * Note that when DIAG = 'U', the diagonal elements of * A are not referenced, but are assumed to be unity. * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element right-hand side vector b. On exit, X is overwritten * with the solution vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. * Unchanged on exit. * * * * * * Level 2 Blas routine. * * -- Written on 11-November-1985. * Sven Hammarling, Nag Central Office. C REVISED 860623 C REVISED YYMMDD C BY R. J. HANSON, SANDIA NATIONAL LABS. * LOGICAL NOUNIT INTEGER I,IX,J,JX,K,KK INTEGER KX REAL ZERO PARAMETER (ZERO=0.0E+0) LOGICAL OK,LSAME OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. . (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR. . LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR. . LSAME(DIAG,'N')) .AND. (N.GT.0) * * Quick return if possible. * IF ( .NOT. OK) RETURN NOUNIT = LSAME(DIAG,'N') * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF (INCX.LE.0) THEN KX = 1 - (N-1)*INCX * ELSE IF (INCX.NE.1) THEN KX = 1 END IF * * Start the operations. In this version the elements of AP are * accessed sequentially with one pass through AP. * IF (LSAME(TRANS,'N')) THEN * * Form x := inv( A )*x. * IF (LSAME(UPLO,'U')) THEN K = (N* (N+1))/2 IF (INCX.EQ.1) THEN DO 20,J = N,1,-1 IF (X(J).NE.ZERO) THEN IF (NOUNIT) X(J) = X(J)/AP(K) K = K - 1 DO 10,I = J - 1,1,-1 X(I) = X(I) - X(J)*AP(K) K = K - 1 10 CONTINUE * ELSE K = K - J END IF * 20 CONTINUE * ELSE JX = KX + (N-1)*INCX DO 40,J = N,1,-1 IF (X(JX).NE.ZERO) THEN IF (NOUNIT) X(JX) = X(JX)/AP(K) IX = JX KK = K - 1 DO 30,K = KK,KK - J + 2,-1 IX = IX - INCX X(IX) = X(IX) - X(JX)*AP(K) 30 CONTINUE * ELSE K = K - J END IF * JX = JX - INCX 40 CONTINUE END IF * ELSE K = 1 IF (INCX.EQ.1) THEN DO 60,J = 1,N IF (X(J).NE.ZERO) THEN IF (NOUNIT) X(J) = X(J)/AP(K) K = K + 1 DO 50,I = J + 1,N X(I) = X(I) - X(J)*AP(K) K = K + 1 50 CONTINUE * ELSE K = K + N - J + 1 END IF * 60 CONTINUE * ELSE JX = KX DO 80,J = 1,N IF (X(JX).NE.ZERO) THEN IF (NOUNIT) X(JX) = X(JX)/AP(K) IX = JX KK = K + 1 DO 70,K = KK,KK + N - (J+1) IX = IX + INCX X(IX) = X(IX) - X(JX)*AP(K) 70 CONTINUE * ELSE K = K + N - J + 1 END IF * JX = JX + INCX 80 CONTINUE END IF * END IF * ELSE * * Form x := inv( A' )*x. * IF (LSAME(UPLO,'U')) THEN K = 1 IF (INCX.EQ.1) THEN DO 100,J = 1,N DO 90,I = 1,J - 1 X(J) = X(J) - AP(K)*X(I) K = K + 1 90 CONTINUE IF (NOUNIT) X(J) = X(J)/AP(K) K = K + 1 100 CONTINUE * ELSE JX = KX DO 120,J = 1,N IX = KX KK = K DO 110,K = KK,KK + J - 2 X(JX) = X(JX) - AP(K)*X(IX) IX = IX + INCX 110 CONTINUE IF (NOUNIT) X(JX) = X(JX)/AP(K) K = K + 1 JX = JX + INCX 120 CONTINUE END IF * ELSE K = (N* (N+1))/2 IF (INCX.EQ.1) THEN DO 140,J = N,1,-1 DO 130,I = N,J + 1,-1 X(J) = X(J) - AP(K)*X(I) K = K - 1 130 CONTINUE IF (NOUNIT) X(J) = X(J)/AP(K) K = K - 1 140 CONTINUE * ELSE KX = KX + (N-1)*INCX JX = KX DO 160,J = N,1,-1 IX = KX KK = K DO 150,K = KK,KK - (N- (J+1)),-1 X(JX) = X(JX) - AP(K)*X(IX) IX = IX - INCX 150 CONTINUE IF (NOUNIT) X(JX) = X(JX)/AP(K) K = K - 1 JX = JX - INCX 160 CONTINUE END IF * END IF * END IF * RETURN * * End of STPSV . * END SUBROUTINE SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) INTEGER M,N,INCX,INCY,LDA REAL ALPHA,X(*),Y(*),A(LDA,*) * * Purpose * ======= * * SGER performs the rank 1 operation * * A := alpha*x*y' + A, * * where alpha is a scalar, x is an m element vector, y is an n element * vector and A is an m by n matrix. * * Parameters * ========== * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( m - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the m * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. * Unchanged on exit. * * Y - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCY ) ). * Before entry, the incremented array Y must contain the n * element vector y. * Unchanged on exit. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. On exit, A is * overwritten by the updated matrix. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least max(1,m). * Unchanged on exit. * * * * Level 2 Blas routine. * * -- Written on 30-August-1985. * Sven Hammarling, Nag Central Office. C REVISED 860623 C REVISED YYMMDD C BY R. J. HANSON, SANDIA NATIONAL LABS. * INTEGER I,IX,J,JY,KX REAL ZERO PARAMETER (ZERO=0.0E+0) REAL TEMP LOGICAL OK OK = (M.GT.0) .AND. (N.GT.0) .AND. (LDA.GE.M) * * * Quick return if possible. * IF ( .NOT. OK .OR. (ALPHA.EQ.ZERO)) RETURN * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 20,J = 1,N IF (Y(J).NE.ZERO) THEN TEMP = ALPHA*Y(J) DO 10,I = 1,M A(I,J) = A(I,J) + X(I)*TEMP 10 CONTINUE END IF * 20 CONTINUE * ELSE IF (INCX.GT.0) THEN KX = 1 * ELSE KX = 1 - (M-1)*INCX END IF * IF (INCY.GT.0) THEN JY = 1 * ELSE JY = 1 - (N-1)*INCY END IF * DO 40,J = 1,N IF (Y(JY).NE.ZERO) THEN TEMP = ALPHA*Y(JY) IX = KX DO 30,I = 1,M A(I,J) = A(I,J) + X(IX)*TEMP IX = IX + INCX 30 CONTINUE END IF * JY = JY + INCY 40 CONTINUE END IF * RETURN * * End of SGER . * END SUBROUTINE SSYR(UPLO,N,ALPHA,X,INCX,A,LDA) CHARACTER *1 UPLO INTEGER N,INCX,LDA REAL ALPHA,X(*),A(LDA,*) * * Purpose * ======= * * SSYR performs the symmetric rank 1 operation * * A := alpha*x*x' + A, * * where alpha is a real scalar, x is an n element vector and A is an * n by n symmetric matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array A is to be referenced as * follows: * * UPLO = 'U' Only the upper triangular part of A * is to be referenced. * * UPLO = 'L' Only the lower triangular part of A * is to be referenced. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U', the leading n by n * upper triangular part of the array A must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of A is not referenced. On exit, the * upper triangular part of the array A is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L', the leading n by n * lower triangular part of the array A must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of A is not referenced. On exit, the * lower triangular part of the array A is overwritten by the * lower triangular part of the updated matrix. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least max(1,n). * Unchanged on exit. * * * * * * Level 2 Blas routine. * * -- Written on 27-September-1985. * Sven Hammarling, Nag Central Office. C REVISED 860623 C REVISED YYMMDD C BY R. J. HANSON, SANDIA NATIONAL LABS. * INTEGER I,IX,J,JX,KX REAL ZERO PARAMETER (ZERO=0.0E+0) REAL TEMP LOGICAL OK,LSAME OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0) .AND. . (LDA.GE.N) * * Quick return if possible. * IF ( .NOT. OK .OR. (ALPHA.EQ.ZERO)) RETURN * * Set the start point in X if the increment is not unity. * IF (INCX.LE.0) THEN KX = 1 - (N-1)*INCX * ELSE IF (INCX.NE.1) THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through the triangular part * of A. * IF (LSAME(UPLO,'U')) THEN * * Form A when A is stored in upper triangle. * IF (INCX.EQ.1) THEN DO 20,J = 1,N IF (X(J).NE.ZERO) THEN TEMP = ALPHA*X(J) DO 10,I = 1,J A(I,J) = A(I,J) + X(I)*TEMP 10 CONTINUE END IF * 20 CONTINUE * ELSE JX = KX DO 40,J = 1,N IF (X(JX).NE.ZERO) THEN TEMP = ALPHA*X(JX) IX = KX DO 30,I = 1,J A(I,J) = A(I,J) + X(IX)*TEMP IX = IX + INCX 30 CONTINUE END IF * JX = JX + INCX 40 CONTINUE END IF * ELSE * * Form A when A is stored in lower triangle. * IF (INCX.EQ.1) THEN DO 60,J = 1,N IF (X(J).NE.ZERO) THEN TEMP = ALPHA*X(J) DO 50,I = J,N A(I,J) = A(I,J) + X(I)*TEMP 50 CONTINUE END IF * 60 CONTINUE * ELSE JX = KX DO 80,J = 1,N IF (X(JX).NE.ZERO) THEN TEMP = ALPHA*X(JX) IX = JX DO 70,I = J,N A(I,J) = A(I,J) + X(IX)*TEMP IX = IX + INCX 70 CONTINUE END IF * JX = JX + INCX 80 CONTINUE END IF * END IF * RETURN * * End of SSYR . * END SUBROUTINE SSPR(UPLO,N,ALPHA,X,INCX,AP) CHARACTER *1 UPLO INTEGER N,INCX REAL ALPHA,X(*),AP(*) * * Purpose * ======= * * SSPR performs the symmetric rank 1 operation * * A := alpha*x*x' + A, * * where alpha is a real scalar, x is an n element vector and A is an * n by n symmetric matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the matrix A is supplied in the packed * array AP as follows: * * UPLO = 'U' The upper triangular part of A is * supplied in AP. * * UPLO = 'L' The lower triangular part of A is * supplied in AP. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. * Unchanged on exit. * * AP - REAL array of DIMENSION at least * ( ( n*( n + 1 ) )/2 ). * Before entry with UPLO = 'U', the array AP must * contain the upper triangular part of the symmetric matrix * packed sequentially, column by column, so that AP( 1 ) * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) * and a( 2, 2 ) respectively, and so on. On exit, the array * AP is overwritten by the upper triangular part of the * updated matrix. * Before entry with UPLO = 'L', the array AP must * contain the lower triangular part of the symmetric matrix * packed sequentially, column by column, so that AP( 1 ) * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) * and a( 3, 1 ) respectively, and so on. On exit, the array * AP is overwritten by the lower triangular part of the * updated matrix. * * * * * Level 2 Blas routine. * * -- Written on 30-September-1985. * Sven Hammarling, Nag Central Office. C REVISED 860623 C REVISED YYMMDD C BY R. J. HANSON, SANDIA NATIONAL LABS. * INTEGER I,IX,J,JX,K,KK INTEGER KX REAL ZERO PARAMETER (ZERO=0.0E+0) REAL TEMP LOGICAL OK,LSAME OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0) * * Quick return if possible. * IF ( .NOT. OK .OR. (ALPHA.EQ.ZERO)) RETURN * * Set the start point in X if the increment is not unity. * IF (INCX.LE.0) THEN KX = 1 - (N-1)*INCX * ELSE IF (INCX.NE.1) THEN KX = 1 END IF * * Start the operations. In this version the elements of the array AP * are accessed sequentially with one pass through AP. * K = 1 IF (LSAME(UPLO,'U')) THEN * * Form A when upper triangle is stored in AP. * IF (INCX.EQ.1) THEN DO 20,J = 1,N IF (X(J).NE.ZERO) THEN TEMP = ALPHA*X(J) DO 10,I = 1,J AP(K) = AP(K) + X(I)*TEMP K = K + 1 10 CONTINUE * ELSE K = K + J END IF * 20 CONTINUE * ELSE JX = KX DO 40,J = 1,N IF (X(JX).NE.ZERO) THEN TEMP = ALPHA*X(JX) IX = KX KK = K DO 30,K = KK,KK + J - 1 AP(K) = AP(K) + X(IX)*TEMP IX = IX + INCX 30 CONTINUE * ELSE K = K + J END IF * JX = JX + INCX 40 CONTINUE END IF * ELSE * * Form A when lower triangle is stored in AP. * IF (INCX.EQ.1) THEN DO 60,J = 1,N IF (X(J).NE.ZERO) THEN TEMP = ALPHA*X(J) DO 50,I = J,N AP(K) = AP(K) + X(I)*TEMP K = K + 1 50 CONTINUE * ELSE K = K + N - J + 1 END IF * 60 CONTINUE * ELSE JX = KX DO 80,J = 1,N IF (X(JX).NE.ZERO) THEN TEMP = ALPHA*X(JX) IX = JX KK = K DO 70,K = KK,KK + N - J AP(K) = AP(K) + X(IX)*TEMP IX = IX + INCX 70 CONTINUE * ELSE K = K + N - J + 1 END IF * JX = JX + INCX 80 CONTINUE END IF * END IF * RETURN * * End of SSPR . * END SUBROUTINE SSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) CHARACTER *1 UPLO INTEGER N,INCX,INCY,LDA REAL ALPHA,X(*),Y(*),A(LDA,*) * * Purpose * ======= * * SSYR2 performs the symmetric rank 2 operation * * A := alpha*x*y' + alpha*y*x' + A, * * where alpha is a scalar, x and y are n element vectors and A is an n * by n symmetric matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array A is to be referenced as * follows: * * UPLO = 'U' Only the upper triangular part of A * is to be referenced. * * UPLO = 'L' Only the lower triangular part of A * is to be referenced. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. * Unchanged on exit. * * Y - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCY ) ). * Before entry, the incremented array Y must contain the n * element vector y. * Unchanged on exit. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U', the leading n by n * upper triangular part of the array A must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of A is not referenced. On exit, the * upper triangular part of the array A is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L', the leading n by n * lower triangular part of the array A must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of A is not referenced. On exit, the * lower triangular part of the array A is overwritten by the * lower triangular part of the updated matrix. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least max(1,n). * Unchanged on exit. * * * * * * Level 2 Blas routine. * * -- Written on 27-September-1985. * Sven Hammarling, Nag Central Office. C REVISED 860623 C REVISED YYMMDD C BY R. J. HANSON, SANDIA NATIONAL LABS. * INTEGER I,IX,IY,J,JX,JY INTEGER KX,KY REAL ZERO PARAMETER (ZERO=0.0E+0) REAL TEMP1,TEMP2 LOGICAL OK,LSAME OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0) .AND. . (LDA.GE.N) * * Quick return if possible. * IF ( .NOT. OK .OR. (ALPHA.EQ.ZERO)) RETURN * * Set up the start points in X and Y if the increments are not both * unity. * IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN IF (INCX.GT.0) THEN KX = 1 * ELSE KX = 1 - (N-1)*INCX END IF * IF (INCY.GT.0) THEN KY = 1 * ELSE KY = 1 - (N-1)*INCY END IF * END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through the triangular part * of A. * IF (LSAME(UPLO,'U')) THEN * * Form A when A is stored in the upper triangle. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 20,J = 1,N IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN TEMP1 = ALPHA*Y(J) TEMP2 = ALPHA*X(J) DO 10,I = 1,J A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 10 CONTINUE END IF * 20 CONTINUE * ELSE JX = KX JY = KY DO 40,J = 1,N IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN TEMP1 = ALPHA*Y(JY) TEMP2 = ALPHA*X(JX) IX = KX IY = KY DO 30,I = 1,J A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 IX = IX + INCX IY = IY + INCY 30 CONTINUE END IF * JX = JX + INCX JY = JY + INCY 40 CONTINUE END IF * ELSE * * Form A when A is stored in the upper triangle. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 60,J = 1,N IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN TEMP1 = ALPHA*Y(J) TEMP2 = ALPHA*X(J) DO 50,I = J,N A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 50 CONTINUE END IF * 60 CONTINUE * ELSE JX = KX JY = KY DO 80,J = 1,N IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN TEMP1 = ALPHA*Y(JY) TEMP2 = ALPHA*X(JX) IX = JX IY = JY DO 70,I = J,N A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 IX = IX + INCX IY = IY + INCY 70 CONTINUE END IF * JX = JX + INCX JY = JY + INCY 80 CONTINUE END IF * END IF * RETURN * * End of SSYR2 . * END SUBROUTINE SSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) CHARACTER *1 UPLO INTEGER N,INCX,INCY REAL ALPHA,X(*),Y(*),AP(*) * * Purpose * ======= * * SSPR2 performs the symmetric rank 2 operation * * A := alpha*x*y' + alpha*y*x' + A, * * where alpha is a scalar, x and y are n element vectors and A is an * n by n symmetric matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the matrix A is supplied in the packed * array AP as follows: * * UPLO = 'U' The upper triangular part of A is * supplied in AP. * * UPLO = 'L' The lower triangular part of A is * supplied in AP. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. * Unchanged on exit. * * Y - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCY ) ). * Before entry, the incremented array Y must contain the n * element vector y. * Unchanged on exit. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. * Unchanged on exit. * * AP - REAL array of DIMENSION at least * ( ( n*( n + 1 ) )/2 ). * Before entry with UPLO = 'U', the array AP must * contain the upper triangular part of the symmetric matrix * packed sequentially, column by column, so that AP( 1 ) * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) * and a( 2, 2 ) respectively, and so on. On exit, the array * AP is overwritten by the upper triangular part of the * updated matrix. * Before entry with UPLO = 'L', the array AP must * contain the lower triangular part of the symmetric matrix * packed sequentially, column by column, so that AP( 1 ) * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) * and a( 3, 1 ) respectively, and so on. On exit, the array * AP is overwritten by the lower triangular part of the * updated matrix. * * * * * * Level 2 Blas routine. * * -- Written on 30-September-1985. * Sven Hammarling, Nag Central Office. C REVISED 860623 C REVISED YYMMDD C BY R. J. HANSON, SANDIA NATIONAL LABS. * INTEGER I,IX,IY,J,JX,JY INTEGER K,KK,KX,KY REAL ZERO PARAMETER (ZERO=0.0E+0) REAL TEMP1,TEMP2 LOGICAL OK,LSAME OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0) * * Quick return if possible. * IF ( .NOT. OK .OR. (ALPHA.EQ.ZERO)) RETURN * * Set up the start points in X and Y if the increments are not both * unity. * IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN IF (INCX.GT.0) THEN KX = 1 * ELSE KX = 1 - (N-1)*INCX END IF * IF (INCY.GT.0) THEN KY = 1 * ELSE KY = 1 - (N-1)*INCY END IF * END IF * * Start the operations. In this version the elements of the array AP * are accessed sequentially with one pass through AP. * K = 1 IF (LSAME(UPLO,'U')) THEN * * Form A when upper triangle is stored in AP. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 20,J = 1,N IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN TEMP1 = ALPHA*Y(J) TEMP2 = ALPHA*X(J) DO 10,I = 1,J AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2 K = K + 1 10 CONTINUE * ELSE K = K + J END IF * 20 CONTINUE * ELSE JX = KX JY = KY DO 40,J = 1,N IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN TEMP1 = ALPHA*Y(JY) TEMP2 = ALPHA*X(JX) IX = KX IY = KY KK = K DO 30,K = KK,KK + J - 1 AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2 IX = IX + INCX IY = IY + INCY 30 CONTINUE * ELSE K = K + J END IF * JX = JX + INCX JY = JY + INCY 40 CONTINUE END IF * ELSE * * Form A when lower triangle is stored in AP. * IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN DO 60,J = 1,N IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN TEMP1 = ALPHA*Y(J) TEMP2 = ALPHA*X(J) DO 50,I = J,N AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2 K = K + 1 50 CONTINUE * ELSE K = K + N - J + 1 END IF * 60 CONTINUE * ELSE JX = KX JY = KY DO 80,J = 1,N IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN TEMP1 = ALPHA*Y(JY) TEMP2 = ALPHA*X(JX) IX = JX IY = JY KK = K DO 70,K = KK,KK + N - J AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2 IX = IX + INCX IY = IY + INCY 70 CONTINUE * ELSE K = K + N - J + 1 END IF * JX = JX + INCX JY = JY + INCY 80 CONTINUE END IF * END IF * RETURN * * End of SSPR2 . * END LOGICAL FUNCTION LSAME(CA,CB) C TEST IF TWO CHARACTERS ARE ESSENTIALLY THE SAME. C THE CHARACTER CB IS ONE OF THE FORTRAN SET. C (LOWER AND UPPER CASE LETTERS ARE EQUIVALENT.) C THIS IS A SUBPROGRAM FOR THE LEVEL TWO BLAS. C REVISED 860623 C REVISED YYMMDD C AUTH=R. J. HANSON, SANDIA NATIONAL LABS. C C THIS SUBPROGRAM IS MACHINE-DEPENDENT. C VERSION FOR CDC SYSTEMS USING 6-12 BIT REPRESENTATIONS. CHARACTER CA(*) CHARACTER *1 CB INTEGER ICIRFX DATA ICIRFX/62/ C SEE IF THE FIRST CHAR. IN STRING CA EQUALS STRING CB. LSAME = CA(1) .EQ. CB .AND. CA(1) .NE. CHAR(ICIRFX) IF (LSAME) RETURN C THE CHARS. ARE NOT IDENTICAL. NOW CHECK THEM FOR EQUIVALENCE. C LOOK FOR THE 'ESCAPE' CHARACTER, CIRCUMFLEX, FOLLOWED BY C THE LETTER. IVAL = ICHAR(CA(2)) IF (IVAL.GE.ICHAR('A') .AND. IVAL.LE.ICHAR('Z')) THEN LSAME = CA(1) .EQ. CHAR(ICIRFX) .AND. CA(2) .EQ. CB END IF * RETURN C END C LOGICAL FUNCTION LSAME(CA,CB) C TEST IF TWO CHARACTERS ARE ESSENTIALLY THE SAME. C THE CHARACTER CB IS ONE OF THE FORTRAN SET. C (LOWER AND UPPER CASE LETTERS ARE EQUIVALENT.) C THIS IS A SUBPROGRAM FOR THE LEVEL TWO BLAS. C REVISED 860623 C REVISED YYMMDD C AUTH=R. J. HANSON, SANDIA NATIONAL LABS. C C THIS SUBPROGRAM IS MACHINE-DEPENDENT. C VERSION FOR ANY ASCII MACHINE. C CHARACTER *1 CA C CHARACTER *1 CB C INTEGER IOFF C DATA IOFF/32/ C SEE IF THE CHAR. IN STRING CA EQUALS STRING CB. C LSAME = CA .EQ. CB C IF (LSAME) RETURN C THE CHARS. ARE NOT IDENTICAL. NOW CHECK THEM FOR EQUIVALENCE. C ISHIFT = ICHAR(CA) - IOFF C IF (ISHIFT.GE.ICHAR('A') .AND. ISHIFT.LE.ICHAR('Z')) THEN C LSAME = ISHIFT .EQ. ICHAR(CB) C END IF C C RETURN C END C C LOGICAL FUNCTION LSAME(CA,CB) C TEST IF TWO CHARACTERS ARE ESSENTIALLY THE SAME. C THE CHARACTER CB IS ONE OF THE FORTRAN SET. C (LOWER AND UPPER CASE LETTERS ARE EQUIVALENT.) C THIS IS A SUBPROGRAM FOR THE LEVEL TWO BLAS. C REVISED 860623 C REVISED YYMMDD C AUTH=R. J. HANSON, SANDIA NATIONAL LABS. C C THIS SUBPROGRAM IS MACHINE-DEPENDENT. C VERSION FOR ANY EBCDIC MACHINE. C CHARACTER *1 CA C CHARACTER *1 CB C INTEGER IOFF C DATA IOFF/64/ C SEE IF THE CHAR. IN STRING CA EQUALS STRING CB. C LSAME = CA .EQ. CB C IF (LSAME) RETURN C THE CHARS. ARE NOT IDENTICAL. NOW CHECK THEM FOR EQUIVALENCE. C ISHIFT = ICHAR(CA) + IOFF C IF (ISHIFT.GE.ICHAR('A') .AND. ISHIFT.LE.ICHAR('I')) THEN C LSAME = ISHIFT .EQ. ICHAR(CB) C END IF C C IF (ISHIFT.GE.ICHAR('J') .AND. ISHIFT.LE.ICHAR('R')) THEN C LSAME = ISHIFT .EQ. ICHAR(CB) C END IF C C IF (ISHIFT.GE.ICHAR('S') .AND. ISHIFT.LE.ICHAR('Z')) THEN C LSAME = ISHIFT .EQ. ICHAR(CB) C END IF C C RETURN C END END subroutine daxpy(n,da,dx,incx,dy,incy) c c constant times a vector plus a vector. c uses unrolled loops for increments equal to one. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dy(*),da integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if (da .eq. 0.0d0) return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c 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 dy(iy) = dy(iy) + da*dx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,4) if( m .eq. 0 ) go to 40 do 30 i = 1,m dy(i) = dy(i) + da*dx(i) 30 continue if( n .lt. 4 ) return 40 mp1 = m + 1 do 50 i = mp1,n,4 dy(i) = dy(i) + da*dx(i) dy(i + 1) = dy(i + 1) + da*dx(i + 1) dy(i + 2) = dy(i + 2) + da*dx(i + 2) dy(i + 3) = dy(i + 3) + da*dx(i + 3) 50 continue return end subroutine dcopy(n,dx,incx,dy,incy) c c copies a vector, x, to a vector, y. c uses unrolled loops for increments equal to one. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dy(*) integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c 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 dy(iy) = dx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,7) if( m .eq. 0 ) go to 40 do 30 i = 1,m dy(i) = dx(i) 30 continue if( n .lt. 7 ) return 40 mp1 = m + 1 do 50 i = mp1,n,7 dy(i) = dx(i) dy(i + 1) = dx(i + 1) dy(i + 2) = dx(i + 2) dy(i + 3) = dx(i + 3) dy(i + 4) = dx(i + 4) dy(i + 5) = dx(i + 5) dy(i + 6) = dx(i + 6) 50 continue return end double precision function ddot(n,dx,incx,dy,incy) c c forms the dot product of two vectors. c uses unrolled loops for increments equal to one. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dy(*),dtemp integer i,incx,incy,ix,iy,m,mp1,n c ddot = 0.0d0 dtemp = 0.0d0 if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c 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 = dtemp + dx(ix)*dy(iy) ix = ix + incx iy = iy + incy 10 continue ddot = dtemp return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m dtemp = dtemp + dx(i)*dy(i) 30 continue if( n .lt. 5 ) go to 60 40 mp1 = m + 1 do 50 i = mp1,n,5 dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) 50 continue 60 ddot = dtemp return end SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 TRANSA, TRANSB INTEGER M, N, K, LDA, LDB, LDC DOUBLE PRECISION ALPHA, BETA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * DGEMM performs one of the matrix-matrix operations * * C := alpha*op( A )*op( B ) + beta*C, * * where op( X ) is one of * * op( X ) = X or op( X ) = X', * * alpha and beta are scalars, and A, B and C are matrices, with op( A ) * an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. * * Parameters * ========== * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n', op( A ) = A. * * TRANSA = 'T' or 't', op( A ) = A'. * * TRANSA = 'C' or 'c', op( A ) = A'. * * Unchanged on exit. * * TRANSB - CHARACTER*1. * On entry, TRANSB specifies the form of op( B ) to be used in * the matrix multiplication as follows: * * TRANSB = 'N' or 'n', op( B ) = B. * * TRANSB = 'T' or 't', op( B ) = B'. * * TRANSB = 'C' or 'c', op( B ) = B'. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix * op( A ) and of the matrix C. M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix * op( B ) and the number of columns of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry, K specifies the number of columns of the matrix * op( A ) and the number of rows of the matrix op( B ). K must * be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is * k when TRANSA = 'N' or 'n', and is m otherwise. * Before entry with TRANSA = 'N' or 'n', the leading m by k * part of the array A must contain the matrix A, otherwise * the leading k by m part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANSA = 'N' or 'n' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, k ). * Unchanged on exit. * * B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is * n when TRANSB = 'N' or 'n', and is k otherwise. * Before entry with TRANSB = 'N' or 'n', the leading k by n * part of the array B must contain the matrix B, otherwise * the leading n by k part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANSB = 'N' or 'n' then * LDB must be at least max( 1, k ), otherwise LDB must be at * least max( 1, n ). * Unchanged on exit. * * BETA - DOUBLE PRECISION. * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n matrix * ( alpha*op( A )*op( B ) + beta*C ). * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. Local Scalars .. LOGICAL NOTA, NOTB INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB DOUBLE PRECISION TEMP * .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Executable Statements .. * * Set NOTA and NOTB as true if A and B respectively are not * transposed and set NROWA, NCOLA and NROWB as the number of rows * and columns of A and the number of rows of B respectively. * NOTA = LSAME( TRANSA, 'N' ) NOTB = LSAME( TRANSB, 'N' ) IF( NOTA )THEN NROWA = M NCOLA = K ELSE NROWA = K NCOLA = M END IF IF( NOTB )THEN NROWB = K ELSE NROWB = N END IF * * Test the input parameters. * INFO = 0 IF( ( .NOT.NOTA ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTB ).AND. $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN INFO = 2 ELSE IF( M .LT.0 )THEN INFO = 3 ELSE IF( N .LT.0 )THEN INFO = 4 ELSE IF( K .LT.0 )THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 8 ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN INFO = 10 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 13 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGEMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And if alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN IF( BETA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE END IF RETURN END IF * * Start the operations. * IF( NOTB )THEN IF( NOTA )THEN * * Form C := alpha*A*B + beta*C. * DO 90, J = 1, N IF( BETA.EQ.ZERO )THEN DO 50, I = 1, M C( I, J ) = ZERO 50 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 60, I = 1, M C( I, J ) = BETA*C( I, J ) 60 CONTINUE END IF DO 80, L = 1, K IF( B( L, J ).NE.ZERO )THEN TEMP = ALPHA*B( L, J ) DO 70, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 70 CONTINUE END IF 80 CONTINUE 90 CONTINUE ELSE * * Form C := alpha*A'*B + beta*C * DO 120, J = 1, N DO 110, I = 1, M TEMP = ZERO DO 100, L = 1, K TEMP = TEMP + A( L, I )*B( L, J ) 100 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 110 CONTINUE 120 CONTINUE END IF ELSE IF( NOTA )THEN * * Form C := alpha*A*B' + beta*C * DO 170, J = 1, N IF( BETA.EQ.ZERO )THEN DO 130, I = 1, M C( I, J ) = ZERO 130 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 140, I = 1, M C( I, J ) = BETA*C( I, J ) 140 CONTINUE END IF DO 160, L = 1, K IF( B( J, L ).NE.ZERO )THEN TEMP = ALPHA*B( J, L ) DO 150, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 150 CONTINUE END IF 160 CONTINUE 170 CONTINUE ELSE * * Form C := alpha*A'*B' + beta*C * DO 200, J = 1, N DO 190, I = 1, M TEMP = ZERO DO 180, L = 1, K TEMP = TEMP + A( L, I )*B( J, L ) 180 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 190 CONTINUE 200 CONTINUE END IF END IF * RETURN * * End of DGEMM . * END SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, $ BETA, Y, INCY ) * .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA INTEGER INCX, INCY, LDA, M, N CHARACTER*1 TRANS * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * DGEMV performs one of the matrix-vector operations * * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, * * where alpha and beta are scalars, x and y are vectors and A is an * m by n matrix. * * Parameters * ========== * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' y := alpha*A*x + beta*y. * * TRANS = 'T' or 't' y := alpha*A'*x + beta*y. * * TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, m ). * Unchanged on exit. * * X - DOUBLE PRECISION array of DIMENSION at least * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. * Before entry, the incremented array X must contain the * vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * BETA - DOUBLE PRECISION. * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then Y need not be set on input. * Unchanged on exit. * * Y - DOUBLE PRECISION array of DIMENSION at least * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. * Before entry with BETA non-zero, the incremented array Y * must contain the vector y. On exit, Y is overwritten by the * updated vector y. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 1 ELSE IF( M.LT.0 )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 ELSE IF( INCY.EQ.0 )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGEMV ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * Set LENX and LENY, the lengths of the vectors x and y, and set * up the start points in X and Y. * IF( LSAME( TRANS, 'N' ) )THEN LENX = N LENY = M ELSE LENX = M LENY = N END IF IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( LENX - 1 )*INCX END IF IF( INCY.GT.0 )THEN KY = 1 ELSE KY = 1 - ( LENY - 1 )*INCY END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * * First form y := beta*y. * IF( BETA.NE.ONE )THEN IF( INCY.EQ.1 )THEN IF( BETA.EQ.ZERO )THEN DO 10, I = 1, LENY Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, LENY Y( I ) = BETA*Y( I ) 20 CONTINUE END IF ELSE IY = KY IF( BETA.EQ.ZERO )THEN DO 30, I = 1, LENY Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, LENY Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE END IF END IF END IF IF( ALPHA.EQ.ZERO ) $ RETURN IF( LSAME( TRANS, 'N' ) )THEN * * Form y := alpha*A*x + y. * JX = KX IF( INCY.EQ.1 )THEN DO 60, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) DO 50, I = 1, M Y( I ) = Y( I ) + TEMP*A( I, J ) 50 CONTINUE END IF JX = JX + INCX 60 CONTINUE ELSE DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) IY = KY DO 70, I = 1, M Y( IY ) = Y( IY ) + TEMP*A( I, J ) IY = IY + INCY 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF ELSE * * Form y := alpha*A'*x + y. * JY = KY IF( INCX.EQ.1 )THEN DO 100, J = 1, N TEMP = ZERO DO 90, I = 1, M TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 100 CONTINUE ELSE DO 120, J = 1, N TEMP = ZERO IX = KX DO 110, I = 1, M TEMP = TEMP + A( I, J )*X( IX ) IX = IX + INCX 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 120 CONTINUE END IF END IF * RETURN * * End of DGEMV . * END SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) * .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX, INCY, LDA, M, N * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * DGER performs the rank 1 operation * * A := alpha*x*y' + A, * * where alpha is a scalar, x is an m element vector, y is an n element * vector and A is an m by n matrix. * * Parameters * ========== * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - DOUBLE PRECISION array of dimension at least * ( 1 + ( m - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the m * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * Y - DOUBLE PRECISION array of dimension at least * ( 1 + ( n - 1 )*abs( INCY ) ). * Before entry, the incremented array Y must contain the n * element vector y. * Unchanged on exit. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. On exit, A is * overwritten by the updated matrix. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, m ). * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JY, KX * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( M.LT.0 )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 5 ELSE IF( INCY.EQ.0 )THEN INFO = 7 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 9 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGER ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) $ RETURN * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( INCY.GT.0 )THEN JY = 1 ELSE JY = 1 - ( N - 1 )*INCY END IF IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*Y( JY ) DO 10, I = 1, M A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE END IF JY = JY + INCY 20 CONTINUE ELSE IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( M - 1 )*INCX END IF DO 40, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*Y( JY ) IX = KX DO 30, I = 1, M A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE END IF JY = JY + INCY 40 CONTINUE END IF * RETURN * * End of DGER . * END DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, N * .. Array Arguments .. DOUBLE PRECISION X( * ) * .. * * DNRM2 returns the euclidean norm of a vector via the function * name, so that * * DNRM2 := sqrt( x'*x ) * * * * -- This version written on 25-October-1982. * Modified on 14-October-1993 to inline the call to DLASSQ. * Sven Hammarling, Nag Ltd. * * * .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. Local Scalars .. INTEGER IX DOUBLE PRECISION ABSXI, NORM, SCALE, SSQ * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. IF( N.LT.1 .OR. INCX.LT.1 )THEN NORM = ZERO ELSE IF( N.EQ.1 )THEN NORM = ABS( X( 1 ) ) ELSE SCALE = ZERO SSQ = ONE * The following loop is equivalent to this call to the LAPACK * auxiliary routine: * CALL DLASSQ( N, X, INCX, SCALE, SSQ ) * DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX IF( X( IX ).NE.ZERO )THEN ABSXI = ABS( X( IX ) ) IF( SCALE.LT.ABSXI )THEN SSQ = ONE + SSQ*( SCALE/ABSXI )**2 SCALE = ABSXI ELSE SSQ = SSQ + ( ABSXI/SCALE )**2 END IF END IF 10 CONTINUE NORM = SCALE * SQRT( SSQ ) END IF * DNRM2 = NORM RETURN * * End of DNRM2. * END subroutine drot (n,dx,incx,dy,incy,c,s) c c applies a plane rotation. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dy(*),dtemp,c,s integer i,incx,incy,ix,iy,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments not equal c to 1 c 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 = c*dx(ix) + s*dy(iy) dy(iy) = c*dy(iy) - s*dx(ix) dx(ix) = dtemp ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c 20 do 30 i = 1,n dtemp = c*dx(i) + s*dy(i) dy(i) = c*dy(i) - s*dx(i) dx(i) = dtemp 30 continue return end subroutine dscal(n,da,dx,incx) c c scales a vector by a constant. c uses unrolled loops for increment equal to one. c jack dongarra, linpack, 3/11/78. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c double precision da,dx(*) integer i,incx,m,mp1,n,nincx c if( n.le.0 .or. incx.le.0 )return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c nincx = n*incx do 10 i = 1,nincx,incx dx(i) = da*dx(i) 10 continue return c c code for increment equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m dx(i) = da*dx(i) 30 continue if( n .lt. 5 ) return 40 mp1 = m + 1 do 50 i = mp1,n,5 dx(i) = da*dx(i) dx(i + 1) = da*dx(i + 1) dx(i + 2) = da*dx(i + 2) dx(i + 3) = da*dx(i + 3) dx(i + 4) = da*dx(i + 4) 50 continue return end subroutine dswap (n,dx,incx,dy,incy) c c interchanges two vectors. c uses unrolled loops for increments equal one. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dy(*),dtemp integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments not equal c to 1 c 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 = dx(ix) dx(ix) = dy(iy) dy(iy) = dtemp ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,3) if( m .eq. 0 ) go to 40 do 30 i = 1,m dtemp = dx(i) dx(i) = dy(i) dy(i) = dtemp 30 continue if( n .lt. 3 ) return 40 mp1 = m + 1 do 50 i = mp1,n,3 dtemp = dx(i) dx(i) = dy(i) dy(i) = dtemp dtemp = dx(i + 1) dx(i + 1) = dy(i + 1) dy(i + 1) = dtemp dtemp = dx(i + 2) dx(i + 2) = dy(i + 2) dy(i + 2) = dtemp 50 continue return end SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ B, LDB ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB DOUBLE PRECISION ALPHA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * DTRMM performs one of the matrix-matrix operations * * B := alpha*op( A )*B, or B := alpha*B*op( A ), * * where alpha is a scalar, B is an m by n matrix, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A'. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) multiplies B from * the left or right as follows: * * SIDE = 'L' or 'l' B := alpha*op( A )*B. * * SIDE = 'R' or 'r' B := alpha*B*op( A ). * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = A'. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of B. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of B. N must be * at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and B need not be set before * entry. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B, and on exit is overwritten by the * transformed matrix. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. Local Scalars .. LOGICAL LSIDE, NOUNIT, UPPER INTEGER I, INFO, J, K, NROWA DOUBLE PRECISION TEMP * .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE , 'L' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF NOUNIT = LSAME( DIAG , 'N' ) UPPER = LSAME( UPLO , 'U' ) * INFO = 0 IF( ( .NOT.LSIDE ).AND. $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND. $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 2 ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN INFO = 4 ELSE IF( M .LT.0 )THEN INFO = 5 ELSE IF( N .LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTRMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( LSAME( TRANSA, 'N' ) )THEN * * Form B := alpha*A*B. * IF( UPPER )THEN DO 50, J = 1, N DO 40, K = 1, M IF( B( K, J ).NE.ZERO )THEN TEMP = ALPHA*B( K, J ) DO 30, I = 1, K - 1 B( I, J ) = B( I, J ) + TEMP*A( I, K ) 30 CONTINUE IF( NOUNIT ) $ TEMP = TEMP*A( K, K ) B( K, J ) = TEMP END IF 40 CONTINUE 50 CONTINUE ELSE DO 80, J = 1, N DO 70 K = M, 1, -1 IF( B( K, J ).NE.ZERO )THEN TEMP = ALPHA*B( K, J ) B( K, J ) = TEMP IF( NOUNIT ) $ B( K, J ) = B( K, J )*A( K, K ) DO 60, I = K + 1, M B( I, J ) = B( I, J ) + TEMP*A( I, K ) 60 CONTINUE END IF 70 CONTINUE 80 CONTINUE END IF ELSE * * Form B := alpha*A'*B. * IF( UPPER )THEN DO 110, J = 1, N DO 100, I = M, 1, -1 TEMP = B( I, J ) IF( NOUNIT ) $ TEMP = TEMP*A( I, I ) DO 90, K = 1, I - 1 TEMP = TEMP + A( K, I )*B( K, J ) 90 CONTINUE B( I, J ) = ALPHA*TEMP 100 CONTINUE 110 CONTINUE ELSE DO 140, J = 1, N DO 130, I = 1, M TEMP = B( I, J ) IF( NOUNIT ) $ TEMP = TEMP*A( I, I ) DO 120, K = I + 1, M TEMP = TEMP + A( K, I )*B( K, J ) 120 CONTINUE B( I, J ) = ALPHA*TEMP 130 CONTINUE 140 CONTINUE END IF END IF ELSE IF( LSAME( TRANSA, 'N' ) )THEN * * Form B := alpha*B*A. * IF( UPPER )THEN DO 180, J = N, 1, -1 TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 150, I = 1, M B( I, J ) = TEMP*B( I, J ) 150 CONTINUE DO 170, K = 1, J - 1 IF( A( K, J ).NE.ZERO )THEN TEMP = ALPHA*A( K, J ) DO 160, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 160 CONTINUE END IF 170 CONTINUE 180 CONTINUE ELSE DO 220, J = 1, N TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 190, I = 1, M B( I, J ) = TEMP*B( I, J ) 190 CONTINUE DO 210, K = J + 1, N IF( A( K, J ).NE.ZERO )THEN TEMP = ALPHA*A( K, J ) DO 200, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 200 CONTINUE END IF 210 CONTINUE 220 CONTINUE END IF ELSE * * Form B := alpha*B*A'. * IF( UPPER )THEN DO 260, K = 1, N DO 240, J = 1, K - 1 IF( A( J, K ).NE.ZERO )THEN TEMP = ALPHA*A( J, K ) DO 230, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 230 CONTINUE END IF 240 CONTINUE TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( K, K ) IF( TEMP.NE.ONE )THEN DO 250, I = 1, M B( I, K ) = TEMP*B( I, K ) 250 CONTINUE END IF 260 CONTINUE ELSE DO 300, K = N, 1, -1 DO 280, J = K + 1, N IF( A( J, K ).NE.ZERO )THEN TEMP = ALPHA*A( J, K ) DO 270, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 270 CONTINUE END IF 280 CONTINUE TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( K, K ) IF( TEMP.NE.ONE )THEN DO 290, I = 1, M B( I, K ) = TEMP*B( I, K ) 290 CONTINUE END IF 300 CONTINUE END IF END IF END IF * RETURN * * End of DTRMM . * END SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ) * .. * * Purpose * ======= * * DTRMV performs one of the matrix-vector operations * * x := A*x, or x := A'*x, * * where x is an n element vector and A is an n by n unit, or non-unit, * upper or lower triangular matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' x := A*x. * * TRANS = 'T' or 't' x := A'*x. * * TRANS = 'C' or 'c' x := A'*x. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * X - DOUBLE PRECISION array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. On exit, X is overwritten with the * tranformed vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTRMV ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * NOUNIT = LSAME( DIAG, 'N' ) * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( LSAME( TRANS, 'N' ) )THEN * * Form x := A*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = X( J ) DO 10, I = 1, J - 1 X( I ) = X( I ) + TEMP*A( I, J ) 10 CONTINUE IF( NOUNIT ) $ X( J ) = X( J )*A( J, J ) END IF 20 CONTINUE ELSE JX = KX DO 40, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = X( JX ) IX = KX DO 30, I = 1, J - 1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX + INCX 30 CONTINUE IF( NOUNIT ) $ X( JX ) = X( JX )*A( J, J ) END IF JX = JX + INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN TEMP = X( J ) DO 50, I = N, J + 1, -1 X( I ) = X( I ) + TEMP*A( I, J ) 50 CONTINUE IF( NOUNIT ) $ X( J ) = X( J )*A( J, J ) END IF 60 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 80, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN TEMP = X( JX ) IX = KX DO 70, I = N, J + 1, -1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX - INCX 70 CONTINUE IF( NOUNIT ) $ X( JX ) = X( JX )*A( J, J ) END IF JX = JX - INCX 80 CONTINUE END IF END IF ELSE * * Form x := A'*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 100, J = N, 1, -1 TEMP = X( J ) IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 90, I = J - 1, 1, -1 TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE X( J ) = TEMP 100 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 120, J = N, 1, -1 TEMP = X( JX ) IX = JX IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 110, I = J - 1, 1, -1 IX = IX - INCX TEMP = TEMP + A( I, J )*X( IX ) 110 CONTINUE X( JX ) = TEMP JX = JX - INCX 120 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 140, J = 1, N TEMP = X( J ) IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 130, I = J + 1, N TEMP = TEMP + A( I, J )*X( I ) 130 CONTINUE X( J ) = TEMP 140 CONTINUE ELSE JX = KX DO 160, J = 1, N TEMP = X( JX ) IX = JX IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 150, I = J + 1, N IX = IX + INCX TEMP = TEMP + A( I, J )*X( IX ) 150 CONTINUE X( JX ) = TEMP JX = JX + INCX 160 CONTINUE END IF END IF END IF * RETURN * * End of DTRMV . * END integer function idamax(n,dx,incx) c c finds the index of element having max. absolute value. c jack dongarra, linpack, 3/11/78. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dmax integer i,incx,ix,n c idamax = 0 if( n.lt.1 .or. incx.le.0 ) return idamax = 1 if(n.eq.1)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 dmax = dabs(dx(1)) ix = ix + incx do 10 i = 2,n if(dabs(dx(ix)).le.dmax) go to 5 idamax = i dmax = dabs(dx(ix)) 5 ix = ix + incx 10 continue return c c code for increment equal to 1 c 20 dmax = dabs(dx(1)) do 30 i = 2,n if(dabs(dx(i)).le.dmax) go to 30 idamax = i dmax = dabs(dx(i)) 30 continue return end SUBROUTINE XERBLA( SRNAME, INFO ) * * -- LAPACK auxiliary routine (preliminary version) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER*6 SRNAME INTEGER INFO * .. * * Purpose * ======= * * XERBLA is an error handler for the LAPACK routines. * It is called by an LAPACK routine if an input parameter has an * invalid value. A message is printed and execution stops. * * Installers may consider modifying the STOP statement in order to * call system-specific exception-handling facilities. * * Arguments * ========= * * SRNAME (input) CHARACTER*6 * The name of the routine which called XERBLA. * * INFO (input) INTEGER * The position of the invalid parameter in the parameter list * of the calling routine. * * WRITE( *, FMT = 9999 )SRNAME, INFO * STOP * 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', $ 'an illegal value' ) * * End of XERBLA * END SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER JOB, SIDE INTEGER IHI, ILO, INFO, LDV, M, N * .. * .. Array Arguments .. DOUBLE PRECISION SCALE( * ), V( LDV, * ) * .. * * Purpose * ======= * * DGEBAK forms the right or left eigenvectors of a real general matrix * by backward transformation on the computed eigenvectors of the * balanced matrix output by DGEBAL. * * Arguments * ========= * * JOB (input) CHARACTER*1 * Specifies the type of backward transformation required: * = 'N', do nothing, return immediately; * = 'P', do backward transformation for permutation only; * = 'S', do backward transformation for scaling only; * = 'B', do backward transformations for both permutation and * scaling. * JOB must be the same as the argument JOB supplied to DGEBAL. * * SIDE (input) CHARACTER*1 * = 'R': V contains right eigenvectors; * = 'L': V contains left eigenvectors. * * N (input) INTEGER * The number of rows of the matrix V. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * The integers ILO and IHI determined by DGEBAL. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * SCALE (input) DOUBLE PRECISION array, dimension (N) * Details of the permutation and scaling factors, as returned * by DGEBAL. * * M (input) INTEGER * The number of columns of the matrix V. M >= 0. * * V (input/output) DOUBLE PRECISION array, dimension (LDV,M) * On entry, the matrix of right or left eigenvectors to be * transformed, as returned by DHSEIN or DTREVC. * On exit, V is overwritten by the transformed eigenvectors. * * LDV (input) INTEGER * The leading dimension of the array V. LDV >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LEFTV, RIGHTV INTEGER I, II, K DOUBLE PRECISION S * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Decode and Test the input parameters * RIGHTV = LSAME( SIDE, 'R' ) LEFTV = LSAME( SIDE, 'L' ) * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -7 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEBAK', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( M.EQ.0 ) $ RETURN IF( LSAME( JOB, 'N' ) ) $ RETURN * IF( ILO.EQ.IHI ) $ GO TO 30 * * Backward balance * IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN * IF( RIGHTV ) THEN DO 10 I = ILO, IHI S = SCALE( I ) CALL DSCAL( M, S, V( I, 1 ), LDV ) 10 CONTINUE END IF * IF( LEFTV ) THEN DO 20 I = ILO, IHI S = ONE / SCALE( I ) CALL DSCAL( M, S, V( I, 1 ), LDV ) 20 CONTINUE END IF * END IF * * Backward permutation * * For I = ILO-1 step -1 until 1, * IHI+1 step 1 until N do -- * 30 CONTINUE IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN IF( RIGHTV ) THEN DO 40 II = 1, N I = II IF( I.GE.ILO .AND. I.LE.IHI ) $ GO TO 40 IF( I.LT.ILO ) $ I = ILO - II K = SCALE( I ) IF( K.EQ.I ) $ GO TO 40 CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 40 CONTINUE END IF * IF( LEFTV ) THEN DO 50 II = 1, N I = II IF( I.GE.ILO .AND. I.LE.IHI ) $ GO TO 50 IF( I.LT.ILO ) $ I = ILO - II K = SCALE( I ) IF( K.EQ.I ) $ GO TO 50 CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 50 CONTINUE END IF END IF * RETURN * * End of DGEBAK * END SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOB INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), SCALE( * ) * .. * * Purpose * ======= * * DGEBAL balances a general real matrix A. This involves, first, * permuting A by a similarity transformation to isolate eigenvalues * in the first 1 to ILO-1 and last IHI+1 to N elements on the * diagonal; and second, applying a diagonal similarity transformation * to rows and columns ILO to IHI to make the rows and columns as * close in norm as possible. Both steps are optional. * * Balancing may reduce the 1-norm of the matrix, and improve the * accuracy of the computed eigenvalues and/or eigenvectors. * * Arguments * ========= * * JOB (input) CHARACTER*1 * Specifies the operations to be performed on A: * = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 * for i = 1,...,N; * = 'P': permute only; * = 'S': scale only; * = 'B': both permute and scale. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the input matrix A. * On exit, A is overwritten by the balanced matrix. * If JOB = 'N', A is not referenced. * See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * ILO (output) INTEGER * IHI (output) INTEGER * ILO and IHI are set to integers such that on exit * A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. * If JOB = 'N' or 'S', ILO = 1 and IHI = N. * * SCALE (output) DOUBLE PRECISION array, dimension (N) * Details of the permutations and scaling factors applied to * A. If P(j) is the index of the row and column interchanged * with row and column j and D(j) is the scaling factor * applied to row and column j, then * SCALE(j) = P(j) for j = 1,...,ILO-1 * = D(j) for j = ILO,...,IHI * = P(j) for j = IHI+1,...,N. * The order in which the interchanges are made is N to IHI+1, * then 1 to ILO-1. * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * The permutations consist of row and column interchanges which put * the matrix in the form * * ( T1 X Y ) * P A P = ( 0 B Z ) * ( 0 0 T2 ) * * where T1 and T2 are upper triangular matrices whose eigenvalues lie * along the diagonal. The column indices ILO and IHI mark the starting * and ending columns of the submatrix B. Balancing consists of applying * a diagonal similarity transformation inv(D) * B * D to make the * 1-norms of each row of B and its corresponding column nearly equal. * The output matrix is * * ( T1 X*D Y ) * ( 0 inv(D)*B*D inv(D)*Z ). * ( 0 0 T2 ) * * Information about the permutations P and the diagonal matrix D is * returned in the vector SCALE. * * This subroutine is based on the EISPACK routine BALANC. * * Modified by Tzu-Yi Chen, Computer Science Division, University of * California at Berkeley, USA * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION SCLFAC PARAMETER ( SCLFAC = 0.8D+1 ) DOUBLE PRECISION FACTOR PARAMETER ( FACTOR = 0.95D+0 ) * .. * .. Local Scalars .. LOGICAL NOCONV INTEGER I, ICA, IEXC, IRA, J, K, L, M DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, $ SFMIN2 * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL LSAME, IDAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEBAL', -INFO ) RETURN END IF * K = 1 L = N * IF( N.EQ.0 ) $ GO TO 210 * IF( LSAME( JOB, 'N' ) ) THEN DO 10 I = 1, N SCALE( I ) = ONE 10 CONTINUE GO TO 210 END IF * IF( LSAME( JOB, 'S' ) ) $ GO TO 120 * * Permutation to isolate eigenvalues if possible * GO TO 50 * * Row and column exchange. * 20 CONTINUE SCALE( M ) = J IF( J.EQ.M ) $ GO TO 30 * CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) CALL DSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA ) * 30 CONTINUE GO TO ( 40, 80 )IEXC * * Search for rows isolating an eigenvalue and push them down. * 40 CONTINUE IF( L.EQ.1 ) $ GO TO 210 L = L - 1 * 50 CONTINUE DO 70 J = L, 1, -1 * DO 60 I = 1, L IF( I.EQ.J ) $ GO TO 60 IF( A( J, I ).NE.ZERO ) $ GO TO 70 60 CONTINUE * M = L IEXC = 1 GO TO 20 70 CONTINUE * GO TO 90 * * Search for columns isolating an eigenvalue and push them left. * 80 CONTINUE K = K + 1 * 90 CONTINUE DO 110 J = K, L * DO 100 I = K, L IF( I.EQ.J ) $ GO TO 100 IF( A( I, J ).NE.ZERO ) $ GO TO 110 100 CONTINUE * M = K IEXC = 2 GO TO 20 110 CONTINUE * 120 CONTINUE DO 130 I = K, L SCALE( I ) = ONE 130 CONTINUE * IF( LSAME( JOB, 'P' ) ) $ GO TO 210 * * Balance the submatrix in rows K to L. * * Iterative loop for norm reduction * SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) SFMAX1 = ONE / SFMIN1 SFMIN2 = SFMIN1*SCLFAC SFMAX2 = ONE / SFMIN2 140 CONTINUE NOCONV = .FALSE. * DO 200 I = K, L C = ZERO R = ZERO * DO 150 J = K, L IF( J.EQ.I ) $ GO TO 150 C = C + ABS( A( J, I ) ) R = R + ABS( A( I, J ) ) 150 CONTINUE ICA = IDAMAX( L, A( 1, I ), 1 ) CA = ABS( A( ICA, I ) ) IRA = IDAMAX( N-K+1, A( I, K ), LDA ) RA = ABS( A( I, IRA+K-1 ) ) * * Guard against zero C or R due to underflow. * IF( C.EQ.ZERO .OR. R.EQ.ZERO ) $ GO TO 200 G = R / SCLFAC F = ONE S = C + R 160 CONTINUE IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170 F = F*SCLFAC C = C*SCLFAC CA = CA*SCLFAC R = R / SCLFAC G = G / SCLFAC RA = RA / SCLFAC GO TO 160 * 170 CONTINUE G = C / SCLFAC 180 CONTINUE IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190 F = F / SCLFAC C = C / SCLFAC G = G / SCLFAC CA = CA / SCLFAC R = R*SCLFAC RA = RA*SCLFAC GO TO 180 * * Now balance. * 190 CONTINUE IF( ( C+R ).GE.FACTOR*S ) $ GO TO 200 IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN IF( F*SCALE( I ).LE.SFMIN1 ) $ GO TO 200 END IF IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN IF( SCALE( I ).GE.SFMAX1 / F ) $ GO TO 200 END IF G = ONE / F SCALE( I ) = SCALE( I )*F NOCONV = .TRUE. * CALL DSCAL( N-K+1, G, A( I, K ), LDA ) CALL DSCAL( L, F, A( 1, I ), 1 ) * 200 CONTINUE * IF( NOCONV ) $ GO TO 140 * 210 CONTINUE ILO = K IHI = L * RETURN * * End of DGEBAL * END SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, $ LDVR, WORK, LWORK, INFO ) * * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * December 8, 1999 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR INTEGER INFO, LDA, LDVL, LDVR, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), $ WI( * ), WORK( * ), WR( * ) * .. * * Purpose * ======= * * DGEEV computes for an N-by-N real nonsymmetric matrix A, the * eigenvalues and, optionally, the left and/or right eigenvectors. * * The right eigenvector v(j) of A satisfies * A * v(j) = lambda(j) * v(j) * where lambda(j) is its eigenvalue. * The left eigenvector u(j) of A satisfies * u(j)**H * A = lambda(j) * u(j)**H * where u(j)**H denotes the conjugate transpose of u(j). * * The computed eigenvectors are normalized to have Euclidean norm * equal to 1 and largest component real. * * Arguments * ========= * * JOBVL (input) CHARACTER*1 * = 'N': left eigenvectors of A are not computed; * = 'V': left eigenvectors of A are computed. * * JOBVR (input) CHARACTER*1 * = 'N': right eigenvectors of A are not computed; * = 'V': right eigenvectors of A are computed. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the N-by-N matrix A. * On exit, A has been overwritten. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * WR (output) DOUBLE PRECISION array, dimension (N) * WI (output) DOUBLE PRECISION array, dimension (N) * WR and WI contain the real and imaginary parts, * respectively, of the computed eigenvalues. Complex * conjugate pairs of eigenvalues appear consecutively * with the eigenvalue having the positive imaginary part * first. * * VL (output) DOUBLE PRECISION array, dimension (LDVL,N) * If JOBVL = 'V', the left eigenvectors u(j) are stored one * after another in the columns of VL, in the same order * as their eigenvalues. * If JOBVL = 'N', VL is not referenced. * If the j-th eigenvalue is real, then u(j) = VL(:,j), * the j-th column of VL. * If the j-th and (j+1)-st eigenvalues form a complex * conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and * u(j+1) = VL(:,j) - i*VL(:,j+1). * * LDVL (input) INTEGER * The leading dimension of the array VL. LDVL >= 1; if * JOBVL = 'V', LDVL >= N. * * VR (output) DOUBLE PRECISION array, dimension (LDVR,N) * If JOBVR = 'V', the right eigenvectors v(j) are stored one * after another in the columns of VR, in the same order * as their eigenvalues. * If JOBVR = 'N', VR is not referenced. * If the j-th eigenvalue is real, then v(j) = VR(:,j), * the j-th column of VR. * If the j-th and (j+1)-st eigenvalues form a complex * conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and * v(j+1) = VR(:,j) - i*VR(:,j+1). * * LDVR (input) INTEGER * The leading dimension of the array VR. LDVR >= 1; if * JOBVR = 'V', LDVR >= N. * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,3*N), and * if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good * performance, LWORK must generally be larger. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value. * > 0: if INFO = i, the QR algorithm failed to compute all the * eigenvalues, and no eigenvectors have been computed; * elements i+1:N of WR and WI contain eigenvalues which * have converged. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, SCALEA, WANTVL, WANTVR CHARACTER SIDE INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K, $ MAXB, MAXWRK, MINWRK, NOUT DOUBLE PRECISION ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM, $ SN * .. * .. Local Arrays .. LOGICAL SELECT( 1 ) DOUBLE PRECISION DUM( 1 ) * .. * .. External Subroutines .. EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, DLARTG, $ DLASCL, DORGHR, DROT, DSCAL, DTREVC, XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX, ILAENV DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2 EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DLANGE, DLAPY2, $ DNRM2 * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) WANTVL = LSAME( JOBVL, 'V' ) WANTVR = LSAME( JOBVR, 'V' ) IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN INFO = -1 ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN INFO = -9 ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN INFO = -11 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed at that point in the code, * as well as the preferred amount for good performance. * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV. * HSWORK refers to the workspace preferred by DHSEQR, as * calculated below. HSWORK is computed assuming ILO=1 and IHI=N, * the worst case.) * MINWRK = 1 IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN MINWRK = MAX( 1, 3*N ) MAXB = MAX( ILAENV( 8, 'DHSEQR', 'EN', N, 1, N, -1 ), 2 ) K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'EN', N, 1, $ N, -1 ) ) ) HSWORK = MAX( K*( K+2 ), 2*N ) MAXWRK = MAX( MAXWRK, N+1, N+HSWORK ) ELSE MINWRK = MAX( 1, 4*N ) MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* $ ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) ) MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SV', N, 1, N, -1 ), 2 ) K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SV', N, 1, $ N, -1 ) ) ) HSWORK = MAX( K*( K+2 ), 2*N ) MAXWRK = MAX( MAXWRK, N+1, N+HSWORK ) MAXWRK = MAX( MAXWRK, 4*N ) END IF WORK( 1 ) = MAXWRK END IF IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEEV ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', N, N, A, LDA, DUM ) SCALEA = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN SCALEA = .TRUE. CSCALE = SMLNUM ELSE IF( ANRM.GT.BIGNUM ) THEN SCALEA = .TRUE. CSCALE = BIGNUM END IF IF( SCALEA ) $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) * * Balance the matrix * (Workspace: need N) * IBAL = 1 CALL DGEBAL( 'B', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR ) * * Reduce to upper Hessenberg form * (Workspace: need 3*N, prefer 2*N+N*NB) * ITAU = IBAL + N IWRK = ITAU + N CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * IF( WANTVL ) THEN * * Want left eigenvectors * Copy Householder vectors to VL * SIDE = 'L' CALL DLACPY( 'L', N, N, A, LDA, VL, LDVL ) * * Generate orthogonal matrix in VL * (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) * CALL DORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * * Perform QR iteration, accumulating Schur vectors in VL * (Workspace: need N+1, prefer N+HSWORK (see comments) ) * IWRK = ITAU CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL, $ WORK( IWRK ), LWORK-IWRK+1, INFO ) * IF( WANTVR ) THEN * * Want left and right eigenvectors * Copy Schur vectors to VR * SIDE = 'B' CALL DLACPY( 'F', N, N, VL, LDVL, VR, LDVR ) END IF * ELSE IF( WANTVR ) THEN * * Want right eigenvectors * Copy Householder vectors to VR * SIDE = 'R' CALL DLACPY( 'L', N, N, A, LDA, VR, LDVR ) * * Generate orthogonal matrix in VR * (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) * CALL DORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ), $ LWORK-IWRK+1, IERR ) * * Perform QR iteration, accumulating Schur vectors in VR * (Workspace: need N+1, prefer N+HSWORK (see comments) ) * IWRK = ITAU CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR, $ WORK( IWRK ), LWORK-IWRK+1, INFO ) * ELSE * * Compute eigenvalues only * (Workspace: need N+1, prefer N+HSWORK (see comments) ) * IWRK = ITAU CALL DHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR, $ WORK( IWRK ), LWORK-IWRK+1, INFO ) END IF * * If INFO > 0 from DHSEQR, then quit * IF( INFO.GT.0 ) $ GO TO 50 * IF( WANTVL .OR. WANTVR ) THEN * * Compute left and/or right eigenvectors * (Workspace: need 4*N) * CALL DTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, $ N, NOUT, WORK( IWRK ), IERR ) END IF * IF( WANTVL ) THEN * * Undo balancing of left eigenvectors * (Workspace: need N) * CALL DGEBAK( 'B', 'L', N, ILO, IHI, WORK( IBAL ), N, VL, LDVL, $ IERR ) * * Normalize left eigenvectors and make largest component real * DO 20 I = 1, N IF( WI( I ).EQ.ZERO ) THEN SCL = ONE / DNRM2( N, VL( 1, I ), 1 ) CALL DSCAL( N, SCL, VL( 1, I ), 1 ) ELSE IF( WI( I ).GT.ZERO ) THEN SCL = ONE / DLAPY2( DNRM2( N, VL( 1, I ), 1 ), $ DNRM2( N, VL( 1, I+1 ), 1 ) ) CALL DSCAL( N, SCL, VL( 1, I ), 1 ) CALL DSCAL( N, SCL, VL( 1, I+1 ), 1 ) DO 10 K = 1, N WORK( IWRK+K-1 ) = VL( K, I )**2 + VL( K, I+1 )**2 10 CONTINUE K = IDAMAX( N, WORK( IWRK ), 1 ) CALL DLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R ) CALL DROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN ) VL( K, I+1 ) = ZERO END IF 20 CONTINUE END IF * IF( WANTVR ) THEN * * Undo balancing of right eigenvectors * (Workspace: need N) * CALL DGEBAK( 'B', 'R', N, ILO, IHI, WORK( IBAL ), N, VR, LDVR, $ IERR ) * * Normalize right eigenvectors and make largest component real * DO 40 I = 1, N IF( WI( I ).EQ.ZERO ) THEN SCL = ONE / DNRM2( N, VR( 1, I ), 1 ) CALL DSCAL( N, SCL, VR( 1, I ), 1 ) ELSE IF( WI( I ).GT.ZERO ) THEN SCL = ONE / DLAPY2( DNRM2( N, VR( 1, I ), 1 ), $ DNRM2( N, VR( 1, I+1 ), 1 ) ) CALL DSCAL( N, SCL, VR( 1, I ), 1 ) CALL DSCAL( N, SCL, VR( 1, I+1 ), 1 ) DO 30 K = 1, N WORK( IWRK+K-1 ) = VR( K, I )**2 + VR( K, I+1 )**2 30 CONTINUE K = IDAMAX( N, WORK( IWRK ), 1 ) CALL DLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R ) CALL DROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN ) VR( K, I+1 ) = ZERO END IF 40 CONTINUE END IF * * Undo scaling if necessary * 50 CONTINUE IF( SCALEA ) THEN CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ), $ MAX( N-INFO, 1 ), IERR ) CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ), $ MAX( N-INFO, 1 ), IERR ) IF( INFO.GT.0 ) THEN CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N, $ IERR ) CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N, $ IERR ) END IF END IF * WORK( 1 ) = MAXWRK RETURN * * End of DGEEV * END SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGEHD2 reduces a real general matrix A to upper Hessenberg form H by * an orthogonal similarity transformation: Q' * A * Q = H . * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that A is already upper triangular in rows * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally * set by a previous call to DGEBAL; otherwise they should be * set to 1 and N respectively. See Further Details. * 1 <= ILO <= IHI <= max(1,N). * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the n by n general matrix to be reduced. * On exit, the upper triangle and the first subdiagonal of A * are overwritten with the upper Hessenberg matrix H, and the * elements below the first subdiagonal, with the array TAU, * represent the orthogonal matrix Q as a product of elementary * reflectors. See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * TAU (output) DOUBLE PRECISION array, dimension (N-1) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) DOUBLE PRECISION array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * The matrix Q is represented as a product of (ihi-ilo) elementary * reflectors * * Q = H(ilo) H(ilo+1) . . . H(ihi-1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a real scalar, and v is a real vector with * v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on * exit in A(i+2:ihi,i), and tau in TAU(i). * * The contents of A are illustrated by the following example, with * n = 7, ilo = 2 and ihi = 6: * * on entry, on exit, * * ( a a a a a a a ) ( a a h h h h a ) * ( a a a a a a ) ( a h h h h a ) * ( a a a a a a ) ( h h h h h h ) * ( a a a a a a ) ( v2 h h h h h ) * ( a a a a a a ) ( v2 v3 h h h h ) * ( a a a a a a ) ( v2 v3 v4 h h h ) * ( a ) ( a ) * * where a denotes an element of the original matrix A, h denotes a * modified element of the upper Hessenberg matrix H, and vi denotes an * element of the vector defining H(i). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION AII * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEHD2', -INFO ) RETURN END IF * DO 10 I = ILO, IHI - 1 * * Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) * CALL DLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, $ TAU( I ) ) AII = A( I+1, I ) A( I+1, I ) = ONE * * Apply H(i) to A(1:ihi,i+1:ihi) from the right * CALL DLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), $ A( 1, I+1 ), LDA, WORK ) * * Apply H(i) to A(i+1:ihi,i+1:n) from the left * CALL DLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ), $ A( I+1, I+1 ), LDA, WORK ) * A( I+1, I ) = AII 10 CONTINUE * RETURN * * End of DGEHD2 * END SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGEHRD reduces a real general matrix A to upper Hessenberg form H by * an orthogonal similarity transformation: Q' * A * Q = H . * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that A is already upper triangular in rows * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally * set by a previous call to DGEBAL; otherwise they should be * set to 1 and N respectively. See Further Details. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the N-by-N general matrix to be reduced. * On exit, the upper triangle and the first subdiagonal of A * are overwritten with the upper Hessenberg matrix H, and the * elements below the first subdiagonal, with the array TAU, * represent the orthogonal matrix Q as a product of elementary * reflectors. See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * TAU (output) DOUBLE PRECISION array, dimension (N-1) * The scalar factors of the elementary reflectors (see Further * Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to * zero. * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= max(1,N). * For optimum performance LWORK >= N*NB, where NB is the * optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * The matrix Q is represented as a product of (ihi-ilo) elementary * reflectors * * Q = H(ilo) H(ilo+1) . . . H(ihi-1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a real scalar, and v is a real vector with * v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on * exit in A(i+2:ihi,i), and tau in TAU(i). * * The contents of A are illustrated by the following example, with * n = 7, ilo = 2 and ihi = 6: * * on entry, on exit, * * ( a a a a a a a ) ( a a h h h h a ) * ( a a a a a a ) ( a h h h h a ) * ( a a a a a a ) ( h h h h h h ) * ( a a a a a a ) ( v2 h h h h h ) * ( a a a a a a ) ( v2 v3 h h h h ) * ( a a a a a a ) ( v2 v3 v4 h h h ) * ( a ) ( a ) * * where a denotes an element of the original matrix A, h denotes a * modified element of the upper Hessenberg matrix H, and vi denotes an * element of the vector defining H(i). * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, LDWORK, LWKOPT, NB, NBMIN, $ NH, NX DOUBLE PRECISION EI * .. * .. Local Arrays .. DOUBLE PRECISION T( LDT, NBMAX ) * .. * .. External Subroutines .. EXTERNAL DGEHD2, DGEMM, DLAHRD, DLARFB, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) LWKOPT = N*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEHRD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Set elements 1:ILO-1 and IHI:N-1 of TAU to zero * DO 10 I = 1, ILO - 1 TAU( I ) = ZERO 10 CONTINUE DO 20 I = MAX( 1, IHI ), N - 1 TAU( I ) = ZERO 20 CONTINUE * * Quick return if possible * NH = IHI - ILO + 1 IF( NH.LE.1 ) THEN WORK( 1 ) = 1 RETURN END IF * * Determine the block size. * NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) NBMIN = 2 IWS = 1 IF( NB.GT.1 .AND. NB.LT.NH ) THEN * * Determine when to cross over from blocked to unblocked code * (last block is always handled by unblocked code). * NX = MAX( NB, ILAENV( 3, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) IF( NX.LT.NH ) THEN * * Determine if workspace is large enough for blocked code. * IWS = N*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: determine the * minimum value of NB, and reduce NB or force use of * unblocked code. * NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N, ILO, IHI, $ -1 ) ) IF( LWORK.GE.N*NBMIN ) THEN NB = LWORK / N ELSE NB = 1 END IF END IF END IF END IF LDWORK = N * IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN * * Use unblocked code below * I = ILO * ELSE * * Use blocked code * DO 30 I = ILO, IHI - 1 - NX, NB IB = MIN( NB, IHI-I ) * * Reduce columns i:i+ib-1 to Hessenberg form, returning the * matrices V and T of the block reflector H = I - V*T*V' * which performs the reduction, and also the matrix Y = A*V*T * CALL DLAHRD( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT, $ WORK, LDWORK ) * * Apply the block reflector H to A(1:ihi,i+ib:ihi) from the * right, computing A := A - Y * V'. V(i+ib,ib-1) must be set * to 1. * EI = A( I+IB, I+IB-1 ) A( I+IB, I+IB-1 ) = ONE CALL DGEMM( 'No transpose', 'Transpose', IHI, IHI-I-IB+1, $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, $ A( 1, I+IB ), LDA ) A( I+IB, I+IB-1 ) = EI * * Apply the block reflector H to A(i+1:ihi,i+ib:n) from the * left * CALL DLARFB( 'Left', 'Transpose', 'Forward', 'Columnwise', $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT, $ A( I+1, I+IB ), LDA, WORK, LDWORK ) 30 CONTINUE END IF * * Use unblocked code to reduce the rest of the matrix * CALL DGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO ) WORK( 1 ) = IWS * RETURN * * End of DGEHRD * END SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, $ LDZ, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER COMPZ, JOB INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), $ Z( LDZ, * ) * .. * * Purpose * ======= * * DHSEQR computes the eigenvalues of a real upper Hessenberg matrix H * and, optionally, the matrices T and Z from the Schur decomposition * H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur * form), and Z is the orthogonal matrix of Schur vectors. * * Optionally Z may be postmultiplied into an input orthogonal matrix Q, * so that this routine can give the Schur factorization of a matrix A * which has been reduced to the Hessenberg form H by the orthogonal * matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. * * Arguments * ========= * * JOB (input) CHARACTER*1 * = 'E': compute eigenvalues only; * = 'S': compute eigenvalues and the Schur form T. * * COMPZ (input) CHARACTER*1 * = 'N': no Schur vectors are computed; * = 'I': Z is initialized to the unit matrix and the matrix Z * of Schur vectors of H is returned; * = 'V': Z must contain an orthogonal matrix Q on entry, and * the product Q*Z is returned. * * N (input) INTEGER * The order of the matrix H. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that H is already upper triangular in rows * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally * set by a previous call to DGEBAL, and then passed to SGEHRD * when the matrix output by DGEBAL is reduced to Hessenberg * form. Otherwise ILO and IHI should be set to 1 and N * respectively. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * H (input/output) DOUBLE PRECISION array, dimension (LDH,N) * On entry, the upper Hessenberg matrix H. * On exit, if JOB = 'S', H contains the upper quasi-triangular * matrix T from the Schur decomposition (the Schur form); * 2-by-2 diagonal blocks (corresponding to complex conjugate * pairs of eigenvalues) are returned in standard form, with * H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If JOB = 'E', * the contents of H are unspecified on exit. * * LDH (input) INTEGER * The leading dimension of the array H. LDH >= max(1,N). * * WR (output) DOUBLE PRECISION array, dimension (N) * WI (output) DOUBLE PRECISION array, dimension (N) * The real and imaginary parts, respectively, of the computed * eigenvalues. If two eigenvalues are computed as a complex * conjugate pair, they are stored in consecutive elements of * WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and * WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in the * same order as on the diagonal of the Schur form returned in * H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 * diagonal block, WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and * WI(i+1) = -WI(i). * * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) * If COMPZ = 'N': Z is not referenced. * If COMPZ = 'I': on entry, Z need not be set, and on exit, Z * contains the orthogonal matrix Z of the Schur vectors of H. * If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q, * which is assumed to be equal to the unit matrix except for * the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z. * Normally Q is the orthogonal matrix generated by DORGHR after * the call to DGEHRD which formed the Hessenberg matrix H. * * LDZ (input) INTEGER * The leading dimension of the array Z. * LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,N). * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, DHSEQR failed to compute all of the * eigenvalues in a total of 30*(IHI-ILO+1) iterations; * elements 1:ilo-1 and i+1:n of WR and WI contain those * eigenvalues which have been successfully computed. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) DOUBLE PRECISION CONST PARAMETER ( CONST = 1.5D+0 ) INTEGER NSMAX, LDS PARAMETER ( NSMAX = 15, LDS = NSMAX ) * .. * .. Local Scalars .. LOGICAL INITZ, LQUERY, WANTT, WANTZ INTEGER I, I1, I2, IERR, II, ITEMP, ITN, ITS, J, K, L, $ MAXB, NH, NR, NS, NV DOUBLE PRECISION ABSW, OVFL, SMLNUM, TAU, TEMP, TST1, ULP, UNFL * .. * .. Local Arrays .. DOUBLE PRECISION S( LDS, NSMAX ), V( NSMAX+1 ), VV( NSMAX+1 ) * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX, ILAENV DOUBLE PRECISION DLAMCH, DLANHS, DLAPY2 EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DLANHS, DLAPY2 * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMV, DLACPY, DLAHQR, DLARFG, DLARFX, $ DLASET, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * * Decode and test the input parameters * WANTT = LSAME( JOB, 'S' ) INITZ = LSAME( COMPZ, 'I' ) WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) * INFO = 0 WORK( 1 ) = MAX( 1, N ) LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -5 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DHSEQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Initialize Z, if necessary * IF( INITZ ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) * * Store the eigenvalues isolated by DGEBAL. * DO 10 I = 1, ILO - 1 WR( I ) = H( I, I ) WI( I ) = ZERO 10 CONTINUE DO 20 I = IHI + 1, N WR( I ) = H( I, I ) WI( I ) = ZERO 20 CONTINUE * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN IF( ILO.EQ.IHI ) THEN WR( ILO ) = H( ILO, ILO ) WI( ILO ) = ZERO RETURN END IF * * Set rows and columns ILO to IHI to zero below the first * subdiagonal. * DO 40 J = ILO, IHI - 2 DO 30 I = J + 2, N H( I, J ) = ZERO 30 CONTINUE 40 CONTINUE NH = IHI - ILO + 1 * * Determine the order of the multi-shift QR algorithm to be used. * NS = ILAENV( 4, 'DHSEQR', JOB // COMPZ, N, ILO, IHI, -1 ) MAXB = ILAENV( 8, 'DHSEQR', JOB // COMPZ, N, ILO, IHI, -1 ) IF( NS.LE.2 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN * * Use the standard double-shift algorithm * CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, $ IHI, Z, LDZ, INFO ) RETURN END IF MAXB = MAX( 3, MAXB ) NS = MIN( NS, MAXB, NSMAX ) * * Now 2 < NS <= MAXB < NH. * * Set machine-dependent constants for the stopping criterion. * If norm(H) <= sqrt(OVFL), overflow should not occur. * UNFL = DLAMCH( 'Safe minimum' ) OVFL = ONE / UNFL CALL DLABAD( UNFL, OVFL ) ULP = DLAMCH( 'Precision' ) SMLNUM = UNFL*( NH / ULP ) * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are * being computed, I1 and I2 are set inside the main loop. * IF( WANTT ) THEN I1 = 1 I2 = N END IF * * ITN is the total number of multiple-shift QR iterations allowed. * ITN = 30*NH * * The main loop begins here. I is the loop index and decreases from * IHI to ILO in steps of at most MAXB. Each iteration of the loop * works with the active submatrix in rows and columns L to I. * Eigenvalues I+1 to IHI have already converged. Either L = ILO or * H(L,L-1) is negligible so that the matrix splits. * I = IHI 50 CONTINUE L = ILO IF( I.LT.ILO ) $ GO TO 170 * * Perform multiple-shift QR iterations on rows and columns ILO to I * until a submatrix of order at most MAXB splits off at the bottom * because a subdiagonal element has become negligible. * DO 150 ITS = 0, ITN * * Look for a single small subdiagonal element. * DO 60 K = I, L + 1, -1 TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) IF( TST1.EQ.ZERO ) $ TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK ) IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) ) $ GO TO 70 60 CONTINUE 70 CONTINUE L = K IF( L.GT.ILO ) THEN * * H(L,L-1) is negligible. * H( L, L-1 ) = ZERO END IF * * Exit from loop if a submatrix of order <= MAXB has split off. * IF( L.GE.I-MAXB+1 ) $ GO TO 160 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix * need be transformed. * IF( .NOT.WANTT ) THEN I1 = L I2 = I END IF * IF( ITS.EQ.20 .OR. ITS.EQ.30 ) THEN * * Exceptional shifts. * DO 80 II = I - NS + 1, I WR( II ) = CONST*( ABS( H( II, II-1 ) )+ $ ABS( H( II, II ) ) ) WI( II ) = ZERO 80 CONTINUE ELSE * * Use eigenvalues of trailing submatrix of order NS as shifts. * CALL DLACPY( 'Full', NS, NS, H( I-NS+1, I-NS+1 ), LDH, S, $ LDS ) CALL DLAHQR( .FALSE., .FALSE., NS, 1, NS, S, LDS, $ WR( I-NS+1 ), WI( I-NS+1 ), 1, NS, Z, LDZ, $ IERR ) IF( IERR.GT.0 ) THEN * * If DLAHQR failed to compute all NS eigenvalues, use the * unconverged diagonal elements as the remaining shifts. * DO 90 II = 1, IERR WR( I-NS+II ) = S( II, II ) WI( I-NS+II ) = ZERO 90 CONTINUE END IF END IF * * Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns)) * where G is the Hessenberg submatrix H(L:I,L:I) and w is * the vector of shifts (stored in WR and WI). The result is * stored in the local array V. * V( 1 ) = ONE DO 100 II = 2, NS + 1 V( II ) = ZERO 100 CONTINUE NV = 1 DO 120 J = I - NS + 1, I IF( WI( J ).GE.ZERO ) THEN IF( WI( J ).EQ.ZERO ) THEN * * real shift * CALL DCOPY( NV+1, V, 1, VV, 1 ) CALL DGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ), $ LDH, VV, 1, -WR( J ), V, 1 ) NV = NV + 1 ELSE IF( WI( J ).GT.ZERO ) THEN * * complex conjugate pair of shifts * CALL DCOPY( NV+1, V, 1, VV, 1 ) CALL DGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ), $ LDH, V, 1, -TWO*WR( J ), VV, 1 ) ITEMP = IDAMAX( NV+1, VV, 1 ) TEMP = ONE / MAX( ABS( VV( ITEMP ) ), SMLNUM ) CALL DSCAL( NV+1, TEMP, VV, 1 ) ABSW = DLAPY2( WR( J ), WI( J ) ) TEMP = ( TEMP*ABSW )*ABSW CALL DGEMV( 'No transpose', NV+2, NV+1, ONE, $ H( L, L ), LDH, VV, 1, TEMP, V, 1 ) NV = NV + 2 END IF * * Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero, * reset it to the unit vector. * ITEMP = IDAMAX( NV, V, 1 ) TEMP = ABS( V( ITEMP ) ) IF( TEMP.EQ.ZERO ) THEN V( 1 ) = ONE DO 110 II = 2, NV V( II ) = ZERO 110 CONTINUE ELSE TEMP = MAX( TEMP, SMLNUM ) CALL DSCAL( NV, ONE / TEMP, V, 1 ) END IF END IF 120 CONTINUE * * Multiple-shift QR step * DO 140 K = L, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, * thus creating a nonzero bulge below the subdiagonal. * * Each subsequent iteration determines a reflection G to * restore the Hessenberg form in the (K-1)th column, and thus * chases the bulge one step toward the bottom of the active * submatrix. NR is the order of G. * NR = MIN( NS+1, I-K+1 ) IF( K.GT.L ) $ CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 ) CALL DLARFG( NR, V( 1 ), V( 2 ), 1, TAU ) IF( K.GT.L ) THEN H( K, K-1 ) = V( 1 ) DO 130 II = K + 1, I H( II, K-1 ) = ZERO 130 CONTINUE END IF V( 1 ) = ONE * * Apply G from the left to transform the rows of the matrix in * columns K to I2. * CALL DLARFX( 'Left', NR, I2-K+1, V, TAU, H( K, K ), LDH, $ WORK ) * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+NR,I). * CALL DLARFX( 'Right', MIN( K+NR, I )-I1+1, NR, V, TAU, $ H( I1, K ), LDH, WORK ) * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * CALL DLARFX( 'Right', NH, NR, V, TAU, Z( ILO, K ), LDZ, $ WORK ) END IF 140 CONTINUE * 150 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * 160 CONTINUE * * A submatrix of order <= MAXB in rows and columns L to I has split * off. Use the double-shift QR algorithm to handle it. * CALL DLAHQR( WANTT, WANTZ, N, L, I, H, LDH, WR, WI, ILO, IHI, Z, $ LDZ, INFO ) IF( INFO.GT.0 ) $ RETURN * * Decrement number of remaining iterations, and return to start of * the main loop with a new value of I. * ITN = ITN - ITS I = L - 1 GO TO 50 * 170 CONTINUE WORK( 1 ) = MAX( 1, N ) RETURN * * End of DHSEQR * END SUBROUTINE DLABAD( SMALL, LARGE ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION LARGE, SMALL * .. * * Purpose * ======= * * DLABAD takes as input the values computed by DLAMCH for underflow and * overflow, and returns the square root of each of these values if the * log of LARGE is sufficiently large. This subroutine is intended to * identify machines with a large exponent range, such as the Crays, and * redefine the underflow and overflow limits to be the square roots of * the values computed by DLAMCH. This subroutine is needed because * DLAMCH does not compensate for poor arithmetic in the upper half of * the exponent range, as is found on a Cray. * * Arguments * ========= * * SMALL (input/output) DOUBLE PRECISION * On entry, the underflow threshold as computed by DLAMCH. * On exit, if LOG10(LARGE) is sufficiently large, the square * root of SMALL, otherwise unchanged. * * LARGE (input/output) DOUBLE PRECISION * On entry, the overflow threshold as computed by DLAMCH. * On exit, if LOG10(LARGE) is sufficiently large, the square * root of LARGE, otherwise unchanged. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC LOG10, SQRT * .. * .. Executable Statements .. * * If it looks like we're on a Cray, take the square root of * SMALL and LARGE to avoid overflow and underflow problems. * IF( LOG10( LARGE ).GT.2000.D0 ) THEN SMALL = SQRT( SMALL ) LARGE = SQRT( LARGE ) END IF * RETURN * * End of DLABAD * END SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, LDB, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * DLACPY copies all or part of a two-dimensional matrix A to another * matrix B. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies the part of the matrix A to be copied to B. * = 'U': Upper triangular part * = 'L': Lower triangular part * Otherwise: All of the matrix A * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,N) * The m by n matrix A. If UPLO = 'U', only the upper triangle * or trapezoid is accessed; if UPLO = 'L', only the lower * triangle or trapezoid is accessed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * B (output) DOUBLE PRECISION array, dimension (LDB,N) * On exit, B = A in the locations specified by UPLO. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,M). * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) B( I, J ) = A( I, J ) 10 CONTINUE 20 CONTINUE ELSE IF( LSAME( UPLO, 'L' ) ) THEN DO 40 J = 1, N DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE 40 CONTINUE ELSE DO 60 J = 1, N DO 50 I = 1, M B( I, J ) = A( I, J ) 50 CONTINUE 60 CONTINUE END IF RETURN * * End of DLACPY * END SUBROUTINE DLADIV( A, B, C, D, P, Q ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, D, P, Q * .. * * Purpose * ======= * * DLADIV performs complex division in real arithmetic * * a + i*b * p + i*q = --------- * c + i*d * * The algorithm is due to Robert L. Smith and can be found * in D. Knuth, The art of Computer Programming, Vol.2, p.195 * * Arguments * ========= * * A (input) DOUBLE PRECISION * B (input) DOUBLE PRECISION * C (input) DOUBLE PRECISION * D (input) DOUBLE PRECISION * The scalars a, b, c, and d in the above expression. * * P (output) DOUBLE PRECISION * Q (output) DOUBLE PRECISION * The scalars p and q in the above expression. * * ===================================================================== * * .. Local Scalars .. DOUBLE PRECISION E, F * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * IF( ABS( D ).LT.ABS( C ) ) THEN E = D / C F = C + D*E P = ( A+B*E ) / F Q = ( B-A*E ) / F ELSE E = C / D F = D + C*E P = ( B+A*E ) / F Q = ( -A+B*E ) / F END IF * RETURN * * End of DLADIV * END SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. LOGICAL WANTT, WANTZ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) * .. * * Purpose * ======= * * DLAHQR is an auxiliary routine called by DHSEQR to update the * eigenvalues and Schur decomposition already computed by DHSEQR, by * dealing with the Hessenberg submatrix in rows and columns ILO to IHI. * * Arguments * ========= * * WANTT (input) LOGICAL * = .TRUE. : the full Schur form T is required; * = .FALSE.: only eigenvalues are required. * * WANTZ (input) LOGICAL * = .TRUE. : the matrix of Schur vectors Z is required; * = .FALSE.: Schur vectors are not required. * * N (input) INTEGER * The order of the matrix H. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that H is already upper quasi-triangular in * rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless * ILO = 1). DLAHQR works primarily with the Hessenberg * submatrix in rows and columns ILO to IHI, but applies * transformations to all of H if WANTT is .TRUE.. * 1 <= ILO <= max(1,IHI); IHI <= N. * * H (input/output) DOUBLE PRECISION array, dimension (LDH,N) * On entry, the upper Hessenberg matrix H. * On exit, if WANTT is .TRUE., H is upper quasi-triangular in * rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in * standard form. If WANTT is .FALSE., the contents of H are * unspecified on exit. * * LDH (input) INTEGER * The leading dimension of the array H. LDH >= max(1,N). * * WR (output) DOUBLE PRECISION array, dimension (N) * WI (output) DOUBLE PRECISION array, dimension (N) * The real and imaginary parts, respectively, of the computed * eigenvalues ILO to IHI are stored in the corresponding * elements of WR and WI. If two eigenvalues are computed as a * complex conjugate pair, they are stored in consecutive * elements of WR and WI, say the i-th and (i+1)th, with * WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the * eigenvalues are stored in the same order as on the diagonal * of the Schur form returned in H, with WR(i) = H(i,i), and, if * H(i:i+1,i:i+1) is a 2-by-2 diagonal block, * WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). * * ILOZ (input) INTEGER * IHIZ (input) INTEGER * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. * 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. * * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) * If WANTZ is .TRUE., on entry Z must contain the current * matrix Z of transformations accumulated by DHSEQR, and on * exit Z has been updated; transformations are applied only to * the submatrix Z(ILOZ:IHIZ,ILO:IHI). * If WANTZ is .FALSE., Z is not referenced. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * > 0: DLAHQR failed to compute all the eigenvalues ILO to IHI * in a total of 30*(IHI-ILO+1) iterations; if INFO = i, * elements i+1:ihi of WR and WI contain those eigenvalues * which have been successfully computed. * * Further Details * =============== * * 2-96 Based on modifications by * David Day, Sandia National Laboratory, USA * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D0 ) DOUBLE PRECISION DAT1, DAT2 PARAMETER ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 ) * .. * .. Local Scalars .. INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NR, NZ DOUBLE PRECISION AVE, CS, DISC, H00, H10, H11, H12, H21, H22, $ H33, H33S, H43H34, H44, H44S, OVFL, S, SMLNUM, $ SN, SUM, T1, T2, T3, TST1, ULP, UNFL, V1, V2, $ V3 * .. * .. Local Arrays .. DOUBLE PRECISION V( 3 ), WORK( 1 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLANHS EXTERNAL DLAMCH, DLANHS * .. * .. External Subroutines .. EXTERNAL DCOPY, DLANV2, DLARFG, DROT * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SIGN, SQRT * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( ILO.EQ.IHI ) THEN WR( ILO ) = H( ILO, ILO ) WI( ILO ) = ZERO RETURN END IF * NH = IHI - ILO + 1 NZ = IHIZ - ILOZ + 1 * * Set machine-dependent constants for the stopping criterion. * If norm(H) <= sqrt(OVFL), overflow should not occur. * UNFL = DLAMCH( 'Safe minimum' ) OVFL = ONE / UNFL CALL DLABAD( UNFL, OVFL ) ULP = DLAMCH( 'Precision' ) SMLNUM = UNFL*( NH / ULP ) * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are * being computed, I1 and I2 are set inside the main loop. * IF( WANTT ) THEN I1 = 1 I2 = N END IF * * ITN is the total number of QR iterations allowed. * ITN = 30*NH * * The main loop begins here. I is the loop index and decreases from * IHI to ILO in steps of 1 or 2. Each iteration of the loop works * with the active submatrix in rows and columns L to I. * Eigenvalues I+1 to IHI have already converged. Either L = ILO or * H(L,L-1) is negligible so that the matrix splits. * I = IHI 10 CONTINUE L = ILO IF( I.LT.ILO ) $ GO TO 150 * * Perform QR iterations on rows and columns ILO to I until a * submatrix of order 1 or 2 splits off at the bottom because a * subdiagonal element has become negligible. * DO 130 ITS = 0, ITN * * Look for a single small subdiagonal element. * DO 20 K = I, L + 1, -1 TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) IF( TST1.EQ.ZERO ) $ TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK ) IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) ) $ GO TO 30 20 CONTINUE 30 CONTINUE L = K IF( L.GT.ILO ) THEN * * H(L,L-1) is negligible * H( L, L-1 ) = ZERO END IF * * Exit from loop if a submatrix of order 1 or 2 has split off. * IF( L.GE.I-1 ) $ GO TO 140 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix * need be transformed. * IF( .NOT.WANTT ) THEN I1 = L I2 = I END IF * IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN * * Exceptional shift. * S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) H44 = DAT1*S + H( I, I ) H33 = H44 H43H34 = DAT2*S*S ELSE * * Prepare to use Francis' double shift * (i.e. 2nd degree generalized Rayleigh quotient) * H44 = H( I, I ) H33 = H( I-1, I-1 ) H43H34 = H( I, I-1 )*H( I-1, I ) S = H( I-1, I-2 )*H( I-1, I-2 ) DISC = ( H33-H44 )*HALF DISC = DISC*DISC + H43H34 IF( DISC.GT.ZERO ) THEN * * Real roots: use Wilkinson's shift twice * DISC = SQRT( DISC ) AVE = HALF*( H33+H44 ) IF( ABS( H33 )-ABS( H44 ).GT.ZERO ) THEN H33 = H33*H44 - H43H34 H44 = H33 / ( SIGN( DISC, AVE )+AVE ) ELSE H44 = SIGN( DISC, AVE ) + AVE END IF H33 = H44 H43H34 = ZERO END IF END IF * * Look for two consecutive small subdiagonal elements. * DO 40 M = I - 2, L, -1 * Determine the effect of starting the double-shift QR * iteration at row M, and see if this would make H(M,M-1) * negligible. * H11 = H( M, M ) H22 = H( M+1, M+1 ) H21 = H( M+1, M ) H12 = H( M, M+1 ) H44S = H44 - H11 H33S = H33 - H11 V1 = ( H33S*H44S-H43H34 ) / H21 + H12 V2 = H22 - H11 - H33S - H44S V3 = H( M+2, M+1 ) S = ABS( V1 ) + ABS( V2 ) + ABS( V3 ) V1 = V1 / S V2 = V2 / S V3 = V3 / S V( 1 ) = V1 V( 2 ) = V2 V( 3 ) = V3 IF( M.EQ.L ) $ GO TO 50 H00 = H( M-1, M-1 ) H10 = H( M, M-1 ) TST1 = ABS( V1 )*( ABS( H00 )+ABS( H11 )+ABS( H22 ) ) IF( ABS( H10 )*( ABS( V2 )+ABS( V3 ) ).LE.ULP*TST1 ) $ GO TO 50 40 CONTINUE 50 CONTINUE * * Double-shift QR step * DO 120 K = M, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, * thus creating a nonzero bulge below the subdiagonal. * * Each subsequent iteration determines a reflection G to * restore the Hessenberg form in the (K-1)th column, and thus * chases the bulge one step toward the bottom of the active * submatrix. NR is the order of G. * NR = MIN( 3, I-K+1 ) IF( K.GT.M ) $ CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 ) CALL DLARFG( NR, V( 1 ), V( 2 ), 1, T1 ) IF( K.GT.M ) THEN H( K, K-1 ) = V( 1 ) H( K+1, K-1 ) = ZERO IF( K.LT.I-1 ) $ H( K+2, K-1 ) = ZERO ELSE IF( M.GT.L ) THEN H( K, K-1 ) = -H( K, K-1 ) END IF V2 = V( 2 ) T2 = T1*V2 IF( NR.EQ.3 ) THEN V3 = V( 3 ) T3 = T1*V3 * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * DO 60 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 H( K+2, J ) = H( K+2, J ) - SUM*T3 60 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * DO 70 J = I1, MIN( K+3, I ) SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 H( J, K+2 ) = H( J, K+2 ) - SUM*T3 70 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * DO 80 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3 80 CONTINUE END IF ELSE IF( NR.EQ.2 ) THEN * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * DO 90 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 90 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * DO 100 J = I1, I SUM = H( J, K ) + V2*H( J, K+1 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 100 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * DO 110 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 110 CONTINUE END IF END IF 120 CONTINUE * 130 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * 140 CONTINUE * IF( L.EQ.I ) THEN * * H(I,I-1) is negligible: one eigenvalue has converged. * WR( I ) = H( I, I ) WI( I ) = ZERO ELSE IF( L.EQ.I-1 ) THEN * * H(I-1,I-2) is negligible: a pair of eigenvalues have converged. * * Transform the 2-by-2 submatrix to standard Schur form, * and compute and store the eigenvalues. * CALL DLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ), $ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ), $ CS, SN ) * IF( WANTT ) THEN * * Apply the transformation to the rest of H. * IF( I2.GT.I ) $ CALL DROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH, $ CS, SN ) CALL DROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN ) END IF IF( WANTZ ) THEN * * Apply the transformation to Z. * CALL DROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN ) END IF END IF * * Decrement number of remaining iterations, and return to start of * the main loop with new value of I. * ITN = ITN - ITS I = L - 1 GO TO 10 * 150 CONTINUE RETURN * * End of DLAHQR * END SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER K, LDA, LDT, LDY, N, NB * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), $ Y( LDY, NB ) * .. * * Purpose * ======= * * DLAHRD reduces the first NB columns of a real general n-by-(n-k+1) * matrix A so that elements below the k-th subdiagonal are zero. The * reduction is performed by an orthogonal similarity transformation * Q' * A * Q. The routine returns the matrices V and T which determine * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. * * This is an auxiliary routine called by DGEHRD. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. * * K (input) INTEGER * The offset for the reduction. Elements below the k-th * subdiagonal in the first NB columns are reduced to zero. * * NB (input) INTEGER * The number of columns to be reduced. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1) * On entry, the n-by-(n-k+1) general matrix A. * On exit, the elements on and above the k-th subdiagonal in * the first NB columns are overwritten with the corresponding * elements of the reduced matrix; the elements below the k-th * subdiagonal, with the array TAU, represent the matrix Q as a * product of elementary reflectors. The other columns of A are * unchanged. See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * TAU (output) DOUBLE PRECISION array, dimension (NB) * The scalar factors of the elementary reflectors. See Further * Details. * * T (output) DOUBLE PRECISION array, dimension (LDT,NB) * The upper triangular matrix T. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= NB. * * Y (output) DOUBLE PRECISION array, dimension (LDY,NB) * The n-by-nb matrix Y. * * LDY (input) INTEGER * The leading dimension of the array Y. LDY >= N. * * Further Details * =============== * * The matrix Q is represented as a product of nb elementary reflectors * * Q = H(1) H(2) . . . H(nb). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a real scalar, and v is a real vector with * v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in * A(i+k+1:n,i), and tau in TAU(i). * * The elements of the vectors v together form the (n-k+1)-by-nb matrix * V which is needed, with T and Y, to apply the transformation to the * unreduced part of the matrix, using an update of the form: * A := (I - V*T*V') * (A - Y*V'). * * The contents of A on exit are illustrated by the following example * with n = 7, k = 3 and nb = 2: * * ( a h a a a ) * ( a h a a a ) * ( a h a a a ) * ( h h a a a ) * ( v1 h a a a ) * ( v1 v2 a a a ) * ( v1 v2 a a a ) * * where a denotes an element of the original matrix A, h denotes a * modified element of the upper Hessenberg matrix H, and vi denotes an * element of the vector defining H(i). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION EI * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DLARFG, DSCAL, DTRMV * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.1 ) $ RETURN * DO 10 I = 1, NB IF( I.GT.1 ) THEN * * Update A(1:n,i) * * Compute i-th column of A - Y * V' * CALL DGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, $ A( K+I-1, 1 ), LDA, ONE, A( 1, I ), 1 ) * * Apply I - V * T' * V' to this column (call it b) from the * left, using the last column of T as workspace * * Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) * ( V2 ) ( b2 ) * * where V1 is unit lower triangular * * w := V1' * b1 * CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) CALL DTRMV( 'Lower', 'Transpose', 'Unit', I-1, A( K+1, 1 ), $ LDA, T( 1, NB ), 1 ) * * w := w + V2'*b2 * CALL DGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ), $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) * * w := T'*w * CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', I-1, T, LDT, $ T( 1, NB ), 1 ) * * b2 := b2 - V2*w * CALL DGEMV( 'No transpose', N-K-I+1, I-1, -ONE, A( K+I, 1 ), $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) * * b1 := b1 - V1*w * CALL DTRMV( 'Lower', 'No transpose', 'Unit', I-1, $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) * A( K+I-1, I-1 ) = EI END IF * * Generate the elementary reflector H(i) to annihilate * A(k+i+1:n,i) * CALL DLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, $ TAU( I ) ) EI = A( K+I, I ) A( K+I, I ) = ONE * * Compute Y(1:n,i) * CALL DGEMV( 'No transpose', N, N-K-I+1, ONE, A( 1, I+1 ), LDA, $ A( K+I, I ), 1, ZERO, Y( 1, I ), 1 ) CALL DGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ), LDA, $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) CALL DGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, T( 1, I ), 1, $ ONE, Y( 1, I ), 1 ) CALL DSCAL( N, TAU( I ), Y( 1, I ), 1 ) * * Compute T(1:i,i) * CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, LDT, $ T( 1, I ), 1 ) T( I, I ) = TAU( I ) * 10 CONTINUE A( K+NB, NB ) = EI * RETURN * * End of DLAHRD * END SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, $ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL LTRANS INTEGER INFO, LDA, LDB, LDX, NA, NW DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. * * Purpose * ======= * * DLALN2 solves a system of the form (ca A - w D ) X = s B * or (ca A' - w D) X = s B with possible scaling ("s") and * perturbation of A. (A' means A-transpose.) * * A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA * real diagonal matrix, w is a real or complex value, and X and B are * NA x 1 matrices -- real if w is real, complex if w is complex. NA * may be 1 or 2. * * If w is complex, X and B are represented as NA x 2 matrices, * the first column of each being the real part and the second * being the imaginary part. * * "s" is a scaling factor (.LE. 1), computed by DLALN2, which is * so chosen that X can be computed without overflow. X is further * scaled if necessary to assure that norm(ca A - w D)*norm(X) is less * than overflow. * * If both singular values of (ca A - w D) are less than SMIN, * SMIN*identity will be used instead of (ca A - w D). If only one * singular value is less than SMIN, one element of (ca A - w D) will be * perturbed enough to make the smallest singular value roughly SMIN. * If both singular values are at least SMIN, (ca A - w D) will not be * perturbed. In any case, the perturbation will be at most some small * multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values * are computed by infinity-norm approximations, and thus will only be * correct to a factor of 2 or so. * * Note: all input quantities are assumed to be smaller than overflow * by a reasonable factor. (See BIGNUM.) * * Arguments * ========== * * LTRANS (input) LOGICAL * =.TRUE.: A-transpose will be used. * =.FALSE.: A will be used (not transposed.) * * NA (input) INTEGER * The size of the matrix A. It may (only) be 1 or 2. * * NW (input) INTEGER * 1 if "w" is real, 2 if "w" is complex. It may only be 1 * or 2. * * SMIN (input) DOUBLE PRECISION * The desired lower bound on the singular values of A. This * should be a safe distance away from underflow or overflow, * say, between (underflow/machine precision) and (machine * precision * overflow ). (See BIGNUM and ULP.) * * CA (input) DOUBLE PRECISION * The coefficient c, which A is multiplied by. * * A (input) DOUBLE PRECISION array, dimension (LDA,NA) * The NA x NA matrix A. * * LDA (input) INTEGER * The leading dimension of A. It must be at least NA. * * D1 (input) DOUBLE PRECISION * The 1,1 element in the diagonal matrix D. * * D2 (input) DOUBLE PRECISION * The 2,2 element in the diagonal matrix D. Not used if NW=1. * * B (input) DOUBLE PRECISION array, dimension (LDB,NW) * The NA x NW matrix B (right-hand side). If NW=2 ("w" is * complex), column 1 contains the real part of B and column 2 * contains the imaginary part. * * LDB (input) INTEGER * The leading dimension of B. It must be at least NA. * * WR (input) DOUBLE PRECISION * The real part of the scalar "w". * * WI (input) DOUBLE PRECISION * The imaginary part of the scalar "w". Not used if NW=1. * * X (output) DOUBLE PRECISION array, dimension (LDX,NW) * The NA x NW matrix X (unknowns), as computed by DLALN2. * If NW=2 ("w" is complex), on exit, column 1 will contain * the real part of X and column 2 will contain the imaginary * part. * * LDX (input) INTEGER * The leading dimension of X. It must be at least NA. * * SCALE (output) DOUBLE PRECISION * The scale factor that B must be multiplied by to insure * that overflow does not occur when computing X. Thus, * (ca A - w D) X will be SCALE*B, not B (ignoring * perturbations of A.) It will be at most 1. * * XNORM (output) DOUBLE PRECISION * The infinity-norm of X, when X is regarded as an NA x NW * real matrix. * * INFO (output) INTEGER * An error flag. It will be set to zero if no error occurs, * a negative number if an argument is in error, or a positive * number if ca A - w D had to be perturbed. * The possible values are: * = 0: No error occurred, and (ca A - w D) did not have to be * perturbed. * = 1: (ca A - w D) had to be perturbed to make its smallest * (or only) singular value greater than SMIN. * NOTE: In the interests of speed, this routine does not * check the inputs for errors. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) * .. * .. Local Scalars .. INTEGER ICMAX, J DOUBLE PRECISION BBND, BI1, BI2, BIGNUM, BNORM, BR1, BR2, CI21, $ CI22, CMAX, CNORM, CR21, CR22, CSI, CSR, LI21, $ LR21, SMINI, SMLNUM, TEMP, U22ABS, UI11, UI11R, $ UI12, UI12S, UI22, UR11, UR11R, UR12, UR12S, $ UR22, XI1, XI2, XR1, XR2 * .. * .. Local Arrays .. LOGICAL RSWAP( 4 ), ZSWAP( 4 ) INTEGER IPIVOT( 4, 4 ) DOUBLE PRECISION CI( 2, 2 ), CIV( 4 ), CR( 2, 2 ), CRV( 4 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DLADIV * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Equivalences .. EQUIVALENCE ( CI( 1, 1 ), CIV( 1 ) ), $ ( CR( 1, 1 ), CRV( 1 ) ) * .. * .. Data statements .. DATA ZSWAP / .FALSE., .FALSE., .TRUE., .TRUE. / DATA RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. / DATA IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4, $ 3, 2, 1 / * .. * .. Executable Statements .. * * Compute BIGNUM * SMLNUM = TWO*DLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM SMINI = MAX( SMIN, SMLNUM ) * * Don't check for input errors * INFO = 0 * * Standard Initializations * SCALE = ONE * IF( NA.EQ.1 ) THEN * * 1 x 1 (i.e., scalar) system C X = B * IF( NW.EQ.1 ) THEN * * Real 1x1 system. * * C = ca A - w D * CSR = CA*A( 1, 1 ) - WR*D1 CNORM = ABS( CSR ) * * If | C | < SMINI, use C = SMINI * IF( CNORM.LT.SMINI ) THEN CSR = SMINI CNORM = SMINI INFO = 1 END IF * * Check scaling for X = B / C * BNORM = ABS( B( 1, 1 ) ) IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*CNORM ) $ SCALE = ONE / BNORM END IF * * Compute X * X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / CSR XNORM = ABS( X( 1, 1 ) ) ELSE * * Complex 1x1 system (w is complex) * * C = ca A - w D * CSR = CA*A( 1, 1 ) - WR*D1 CSI = -WI*D1 CNORM = ABS( CSR ) + ABS( CSI ) * * If | C | < SMINI, use C = SMINI * IF( CNORM.LT.SMINI ) THEN CSR = SMINI CSI = ZERO CNORM = SMINI INFO = 1 END IF * * Check scaling for X = B / C * BNORM = ABS( B( 1, 1 ) ) + ABS( B( 1, 2 ) ) IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*CNORM ) $ SCALE = ONE / BNORM END IF * * Compute X * CALL DLADIV( SCALE*B( 1, 1 ), SCALE*B( 1, 2 ), CSR, CSI, $ X( 1, 1 ), X( 1, 2 ) ) XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) END IF * ELSE * * 2x2 System * * Compute the real part of C = ca A - w D (or ca A' - w D ) * CR( 1, 1 ) = CA*A( 1, 1 ) - WR*D1 CR( 2, 2 ) = CA*A( 2, 2 ) - WR*D2 IF( LTRANS ) THEN CR( 1, 2 ) = CA*A( 2, 1 ) CR( 2, 1 ) = CA*A( 1, 2 ) ELSE CR( 2, 1 ) = CA*A( 2, 1 ) CR( 1, 2 ) = CA*A( 1, 2 ) END IF * IF( NW.EQ.1 ) THEN * * Real 2x2 system (w is real) * * Find the largest element in C * CMAX = ZERO ICMAX = 0 * DO 10 J = 1, 4 IF( ABS( CRV( J ) ).GT.CMAX ) THEN CMAX = ABS( CRV( J ) ) ICMAX = J END IF 10 CONTINUE * * If norm(C) < SMINI, use SMINI*identity. * IF( CMAX.LT.SMINI ) THEN BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 2, 1 ) ) ) IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*SMINI ) $ SCALE = ONE / BNORM END IF TEMP = SCALE / SMINI X( 1, 1 ) = TEMP*B( 1, 1 ) X( 2, 1 ) = TEMP*B( 2, 1 ) XNORM = TEMP*BNORM INFO = 1 RETURN END IF * * Gaussian elimination with complete pivoting. * UR11 = CRV( ICMAX ) CR21 = CRV( IPIVOT( 2, ICMAX ) ) UR12 = CRV( IPIVOT( 3, ICMAX ) ) CR22 = CRV( IPIVOT( 4, ICMAX ) ) UR11R = ONE / UR11 LR21 = UR11R*CR21 UR22 = CR22 - UR12*LR21 * * If smaller pivot < SMINI, use SMINI * IF( ABS( UR22 ).LT.SMINI ) THEN UR22 = SMINI INFO = 1 END IF IF( RSWAP( ICMAX ) ) THEN BR1 = B( 2, 1 ) BR2 = B( 1, 1 ) ELSE BR1 = B( 1, 1 ) BR2 = B( 2, 1 ) END IF BR2 = BR2 - LR21*BR1 BBND = MAX( ABS( BR1*( UR22*UR11R ) ), ABS( BR2 ) ) IF( BBND.GT.ONE .AND. ABS( UR22 ).LT.ONE ) THEN IF( BBND.GE.BIGNUM*ABS( UR22 ) ) $ SCALE = ONE / BBND END IF * XR2 = ( BR2*SCALE ) / UR22 XR1 = ( SCALE*BR1 )*UR11R - XR2*( UR11R*UR12 ) IF( ZSWAP( ICMAX ) ) THEN X( 1, 1 ) = XR2 X( 2, 1 ) = XR1 ELSE X( 1, 1 ) = XR1 X( 2, 1 ) = XR2 END IF XNORM = MAX( ABS( XR1 ), ABS( XR2 ) ) * * Further scaling if norm(A) norm(X) > overflow * IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN IF( XNORM.GT.BIGNUM / CMAX ) THEN TEMP = CMAX / BIGNUM X( 1, 1 ) = TEMP*X( 1, 1 ) X( 2, 1 ) = TEMP*X( 2, 1 ) XNORM = TEMP*XNORM SCALE = TEMP*SCALE END IF END IF ELSE * * Complex 2x2 system (w is complex) * * Find the largest element in C * CI( 1, 1 ) = -WI*D1 CI( 2, 1 ) = ZERO CI( 1, 2 ) = ZERO CI( 2, 2 ) = -WI*D2 CMAX = ZERO ICMAX = 0 * DO 20 J = 1, 4 IF( ABS( CRV( J ) )+ABS( CIV( J ) ).GT.CMAX ) THEN CMAX = ABS( CRV( J ) ) + ABS( CIV( J ) ) ICMAX = J END IF 20 CONTINUE * * If norm(C) < SMINI, use SMINI*identity. * IF( CMAX.LT.SMINI ) THEN BNORM = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ), $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) ) IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*SMINI ) $ SCALE = ONE / BNORM END IF TEMP = SCALE / SMINI X( 1, 1 ) = TEMP*B( 1, 1 ) X( 2, 1 ) = TEMP*B( 2, 1 ) X( 1, 2 ) = TEMP*B( 1, 2 ) X( 2, 2 ) = TEMP*B( 2, 2 ) XNORM = TEMP*BNORM INFO = 1 RETURN END IF * * Gaussian elimination with complete pivoting. * UR11 = CRV( ICMAX ) UI11 = CIV( ICMAX ) CR21 = CRV( IPIVOT( 2, ICMAX ) ) CI21 = CIV( IPIVOT( 2, ICMAX ) ) UR12 = CRV( IPIVOT( 3, ICMAX ) ) UI12 = CIV( IPIVOT( 3, ICMAX ) ) CR22 = CRV( IPIVOT( 4, ICMAX ) ) CI22 = CIV( IPIVOT( 4, ICMAX ) ) IF( ICMAX.EQ.1 .OR. ICMAX.EQ.4 ) THEN * * Code when off-diagonals of pivoted C are real * IF( ABS( UR11 ).GT.ABS( UI11 ) ) THEN TEMP = UI11 / UR11 UR11R = ONE / ( UR11*( ONE+TEMP**2 ) ) UI11R = -TEMP*UR11R ELSE TEMP = UR11 / UI11 UI11R = -ONE / ( UI11*( ONE+TEMP**2 ) ) UR11R = -TEMP*UI11R END IF LR21 = CR21*UR11R LI21 = CR21*UI11R UR12S = UR12*UR11R UI12S = UR12*UI11R UR22 = CR22 - UR12*LR21 UI22 = CI22 - UR12*LI21 ELSE * * Code when diagonals of pivoted C are real * UR11R = ONE / UR11 UI11R = ZERO LR21 = CR21*UR11R LI21 = CI21*UR11R UR12S = UR12*UR11R UI12S = UI12*UR11R UR22 = CR22 - UR12*LR21 + UI12*LI21 UI22 = -UR12*LI21 - UI12*LR21 END IF U22ABS = ABS( UR22 ) + ABS( UI22 ) * * If smaller pivot < SMINI, use SMINI * IF( U22ABS.LT.SMINI ) THEN UR22 = SMINI UI22 = ZERO INFO = 1 END IF IF( RSWAP( ICMAX ) ) THEN BR2 = B( 1, 1 ) BR1 = B( 2, 1 ) BI2 = B( 1, 2 ) BI1 = B( 2, 2 ) ELSE BR1 = B( 1, 1 ) BR2 = B( 2, 1 ) BI1 = B( 1, 2 ) BI2 = B( 2, 2 ) END IF BR2 = BR2 - LR21*BR1 + LI21*BI1 BI2 = BI2 - LI21*BR1 - LR21*BI1 BBND = MAX( ( ABS( BR1 )+ABS( BI1 ) )* $ ( U22ABS*( ABS( UR11R )+ABS( UI11R ) ) ), $ ABS( BR2 )+ABS( BI2 ) ) IF( BBND.GT.ONE .AND. U22ABS.LT.ONE ) THEN IF( BBND.GE.BIGNUM*U22ABS ) THEN SCALE = ONE / BBND BR1 = SCALE*BR1 BI1 = SCALE*BI1 BR2 = SCALE*BR2 BI2 = SCALE*BI2 END IF END IF * CALL DLADIV( BR2, BI2, UR22, UI22, XR2, XI2 ) XR1 = UR11R*BR1 - UI11R*BI1 - UR12S*XR2 + UI12S*XI2 XI1 = UI11R*BR1 + UR11R*BI1 - UI12S*XR2 - UR12S*XI2 IF( ZSWAP( ICMAX ) ) THEN X( 1, 1 ) = XR2 X( 2, 1 ) = XR1 X( 1, 2 ) = XI2 X( 2, 2 ) = XI1 ELSE X( 1, 1 ) = XR1 X( 2, 1 ) = XR2 X( 1, 2 ) = XI1 X( 2, 2 ) = XI2 END IF XNORM = MAX( ABS( XR1 )+ABS( XI1 ), ABS( XR2 )+ABS( XI2 ) ) * * Further scaling if norm(A) norm(X) > overflow * IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN IF( XNORM.GT.BIGNUM / CMAX ) THEN TEMP = CMAX / BIGNUM X( 1, 1 ) = TEMP*X( 1, 1 ) X( 2, 1 ) = TEMP*X( 2, 1 ) X( 1, 2 ) = TEMP*X( 1, 2 ) X( 2, 2 ) = TEMP*X( 2, 2 ) XNORM = TEMP*XNORM SCALE = TEMP*SCALE END IF END IF END IF END IF * RETURN * * End of DLALN2 * END DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER CMACH * .. * * Purpose * ======= * * DLAMCH determines double precision machine parameters. * * Arguments * ========= * * CMACH (input) CHARACTER*1 * Specifies the value to be returned by DLAMCH: * = 'E' or 'e', DLAMCH := eps * = 'S' or 's , DLAMCH := sfmin * = 'B' or 'b', DLAMCH := base * = 'P' or 'p', DLAMCH := eps*base * = 'N' or 'n', DLAMCH := t * = 'R' or 'r', DLAMCH := rnd * = 'M' or 'm', DLAMCH := emin * = 'U' or 'u', DLAMCH := rmin * = 'L' or 'l', DLAMCH := emax * = 'O' or 'o', DLAMCH := rmax * * where * * eps = relative machine precision * sfmin = safe minimum, such that 1/sfmin does not overflow * base = base of the machine * prec = eps*base * t = number of (base) digits in the mantissa * rnd = 1.0 when rounding occurs in addition, 0.0 otherwise * emin = minimum exponent before (gradual) underflow * rmin = underflow threshold - base**(emin-1) * emax = largest exponent before overflow * rmax = overflow threshold - (base**emax)*(1-eps) * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL FIRST, LRND INTEGER BETA, IMAX, IMIN, IT DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, $ RND, SFMIN, SMALL, T * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLAMC2 * .. * .. Save statement .. SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, $ EMAX, RMAX, PREC * .. * .. Data statements .. DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) BASE = BETA T = IT IF( LRND ) THEN RND = ONE EPS = ( BASE**( 1-IT ) ) / 2 ELSE RND = ZERO EPS = BASE**( 1-IT ) END IF PREC = EPS*BASE EMIN = IMIN EMAX = IMAX SFMIN = RMIN SMALL = ONE / RMAX IF( SMALL.GE.SFMIN ) THEN * * Use SMALL plus a bit, to avoid the possibility of rounding * causing overflow when computing 1/sfmin. * SFMIN = SMALL*( ONE+EPS ) END IF END IF * IF( LSAME( CMACH, 'E' ) ) THEN RMACH = EPS ELSE IF( LSAME( CMACH, 'S' ) ) THEN RMACH = SFMIN ELSE IF( LSAME( CMACH, 'B' ) ) THEN RMACH = BASE ELSE IF( LSAME( CMACH, 'P' ) ) THEN RMACH = PREC ELSE IF( LSAME( CMACH, 'N' ) ) THEN RMACH = T ELSE IF( LSAME( CMACH, 'R' ) ) THEN RMACH = RND ELSE IF( LSAME( CMACH, 'M' ) ) THEN RMACH = EMIN ELSE IF( LSAME( CMACH, 'U' ) ) THEN RMACH = RMIN ELSE IF( LSAME( CMACH, 'L' ) ) THEN RMACH = EMAX ELSE IF( LSAME( CMACH, 'O' ) ) THEN RMACH = RMAX END IF * DLAMCH = RMACH RETURN * * End of DLAMCH * END * ************************************************************************ * SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL IEEE1, RND INTEGER BETA, T * .. * * Purpose * ======= * * DLAMC1 determines the machine parameters given by BETA, T, RND, and * IEEE1. * * Arguments * ========= * * BETA (output) INTEGER * The base of the machine. * * T (output) INTEGER * The number of ( BETA ) digits in the mantissa. * * RND (output) LOGICAL * Specifies whether proper rounding ( RND = .TRUE. ) or * chopping ( RND = .FALSE. ) occurs in addition. This may not * be a reliable guide to the way in which the machine performs * its arithmetic. * * IEEE1 (output) LOGICAL * Specifies whether rounding appears to be done in the IEEE * 'round to nearest' style. * * Further Details * =============== * * The routine is based on the routine ENVRON by Malcolm and * incorporates suggestions by Gentleman and Marovich. See * * Malcolm M. A. (1972) Algorithms to reveal properties of * floating-point arithmetic. Comms. of the ACM, 15, 949-951. * * Gentleman W. M. and Marovich S. B. (1974) More on algorithms * that reveal properties of floating point arithmetic units. * Comms. of the ACM, 17, 276-277. * * ===================================================================== * * .. Local Scalars .. LOGICAL FIRST, LIEEE1, LRND INTEGER LBETA, LT DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 * .. * .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 * .. * .. Save statement .. SAVE FIRST, LIEEE1, LBETA, LRND, LT * .. * .. Data statements .. DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. ONE = 1 * * LBETA, LIEEE1, LT and LRND are the local values of BETA, * IEEE1, T and RND. * * Throughout this routine we use the function DLAMC3 to ensure * that relevant values are stored and not held in registers, or * are not affected by optimizers. * * Compute a = 2.0**m with the smallest positive integer m such * that * * fl( a + 1.0 ) = a. * A = 1 C = 1 * *+ WHILE( C.EQ.ONE )LOOP 10 CONTINUE IF( C.EQ.ONE ) THEN A = 2*A C = DLAMC3( A, ONE ) C = DLAMC3( C, -A ) GO TO 10 END IF *+ END WHILE * * Now compute b = 2.0**m with the smallest positive integer m * such that * * fl( a + b ) .gt. a. * B = 1 C = DLAMC3( A, B ) * *+ WHILE( C.EQ.A )LOOP 20 CONTINUE IF( C.EQ.A ) THEN B = 2*B C = DLAMC3( A, B ) GO TO 20 END IF *+ END WHILE * * Now compute the base. a and c are neighbouring floating point * numbers in the interval ( beta**t, beta**( t + 1 ) ) and so * their difference is beta. Adding 0.25 to c is to ensure that it * is truncated to beta and not ( beta - 1 ). * QTR = ONE / 4 SAVEC = C C = DLAMC3( C, -A ) LBETA = C + QTR * * Now determine whether rounding or chopping occurs, by adding a * bit less than beta/2 and a bit more than beta/2 to a. * B = LBETA F = DLAMC3( B / 2, -B / 100 ) C = DLAMC3( F, A ) IF( C.EQ.A ) THEN LRND = .TRUE. ELSE LRND = .FALSE. END IF F = DLAMC3( B / 2, B / 100 ) C = DLAMC3( F, A ) IF( ( LRND ) .AND. ( C.EQ.A ) ) $ LRND = .FALSE. * * Try and decide whether rounding is done in the IEEE 'round to * nearest' style. B/2 is half a unit in the last place of the two * numbers A and SAVEC. Furthermore, A is even, i.e. has last bit * zero, and SAVEC is odd. Thus adding B/2 to A should not change * A, but adding B/2 to SAVEC should change SAVEC. * T1 = DLAMC3( B / 2, A ) T2 = DLAMC3( B / 2, SAVEC ) LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND * * Now find the mantissa, t. It should be the integer part of * log to the base beta of a, however it is safer to determine t * by powering. So we find t as the smallest positive integer for * which * * fl( beta**t + 1.0 ) = 1.0. * LT = 0 A = 1 C = 1 * *+ WHILE( C.EQ.ONE )LOOP 30 CONTINUE IF( C.EQ.ONE ) THEN LT = LT + 1 A = A*LBETA C = DLAMC3( A, ONE ) C = DLAMC3( C, -A ) GO TO 30 END IF *+ END WHILE * END IF * BETA = LBETA T = LT RND = LRND IEEE1 = LIEEE1 RETURN * * End of DLAMC1 * END * ************************************************************************ * SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL RND INTEGER BETA, EMAX, EMIN, T DOUBLE PRECISION EPS, RMAX, RMIN * .. * * Purpose * ======= * * DLAMC2 determines the machine parameters specified in its argument * list. * * Arguments * ========= * * BETA (output) INTEGER * The base of the machine. * * T (output) INTEGER * The number of ( BETA ) digits in the mantissa. * * RND (output) LOGICAL * Specifies whether proper rounding ( RND = .TRUE. ) or * chopping ( RND = .FALSE. ) occurs in addition. This may not * be a reliable guide to the way in which the machine performs * its arithmetic. * * EPS (output) DOUBLE PRECISION * The smallest positive number such that * * fl( 1.0 - EPS ) .LT. 1.0, * * where fl denotes the computed value. * * EMIN (output) INTEGER * The minimum exponent before (gradual) underflow occurs. * * RMIN (output) DOUBLE PRECISION * The smallest normalized number for the machine, given by * BASE**( EMIN - 1 ), where BASE is the floating point value * of BETA. * * EMAX (output) INTEGER * The maximum exponent before overflow occurs. * * RMAX (output) DOUBLE PRECISION * The largest positive number for the machine, given by * BASE**EMAX * ( 1 - EPS ), where BASE is the floating point * value of BETA. * * Further Details * =============== * * The computation of EPS is based on a routine PARANOIA by * W. Kahan of the University of California at Berkeley. * * ===================================================================== * * .. Local Scalars .. LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, $ NGNMIN, NGPMIN DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, $ SIXTH, SMALL, THIRD, TWO, ZERO * .. * .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 * .. * .. External Subroutines .. EXTERNAL DLAMC1, DLAMC4, DLAMC5 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Save statement .. SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, $ LRMIN, LT * .. * .. Data statements .. DATA FIRST / .TRUE. / , IWARN / .FALSE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. ZERO = 0 ONE = 1 TWO = 2 * * LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of * BETA, T, RND, EPS, EMIN and RMIN. * * Throughout this routine we use the function DLAMC3 to ensure * that relevant values are stored and not held in registers, or * are not affected by optimizers. * * DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. * CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) * * Start to find EPS. * B = LBETA A = B**( -LT ) LEPS = A * * Try some tricks to see whether or not this is the correct EPS. * B = TWO / 3 HALF = ONE / 2 SIXTH = DLAMC3( B, -HALF ) THIRD = DLAMC3( SIXTH, SIXTH ) B = DLAMC3( THIRD, -HALF ) B = DLAMC3( B, SIXTH ) B = ABS( B ) IF( B.LT.LEPS ) $ B = LEPS * LEPS = 1 * *+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP 10 CONTINUE IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN LEPS = B C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) C = DLAMC3( HALF, -C ) B = DLAMC3( HALF, C ) C = DLAMC3( HALF, -B ) B = DLAMC3( HALF, C ) GO TO 10 END IF *+ END WHILE * IF( A.LT.LEPS ) $ LEPS = A * * Computation of EPS complete. * * Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). * Keep dividing A by BETA until (gradual) underflow occurs. This * is detected when we cannot recover the previous A. * RBASE = ONE / LBETA SMALL = ONE DO 20 I = 1, 3 SMALL = DLAMC3( SMALL*RBASE, ZERO ) 20 CONTINUE A = DLAMC3( ONE, SMALL ) CALL DLAMC4( NGPMIN, ONE, LBETA ) CALL DLAMC4( NGNMIN, -ONE, LBETA ) CALL DLAMC4( GPMIN, A, LBETA ) CALL DLAMC4( GNMIN, -A, LBETA ) IEEE = .FALSE. * IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN IF( NGPMIN.EQ.GPMIN ) THEN LEMIN = NGPMIN * ( Non twos-complement machines, no gradual underflow; * e.g., VAX ) ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN LEMIN = NGPMIN - 1 + LT IEEE = .TRUE. * ( Non twos-complement machines, with gradual underflow; * e.g., IEEE standard followers ) ELSE LEMIN = MIN( NGPMIN, GPMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF * ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN LEMIN = MAX( NGPMIN, NGNMIN ) * ( Twos-complement machines, no gradual underflow; * e.g., CYBER 205 ) ELSE LEMIN = MIN( NGPMIN, NGNMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF * ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. $ ( GPMIN.EQ.GNMIN ) ) THEN IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT * ( Twos-complement machines with gradual underflow; * no known machine ) ELSE LEMIN = MIN( NGPMIN, NGNMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF * ELSE LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF *** * Comment out this if block if EMIN is ok IF( IWARN ) THEN FIRST = .TRUE. WRITE( 6, FMT = 9999 )LEMIN END IF *** * * Assume IEEE arithmetic if we found denormalised numbers above, * or if arithmetic seems to round in the IEEE style, determined * in routine DLAMC1. A true IEEE machine should have both things * true; however, faulty machines may have one or the other. * IEEE = IEEE .OR. LIEEE1 * * Compute RMIN by successive division by BETA. We could compute * RMIN as BASE**( EMIN - 1 ), but some machines underflow during * this computation. * LRMIN = 1 DO 30 I = 1, 1 - LEMIN LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) 30 CONTINUE * * Finally, call DLAMC5 to compute EMAX and RMAX. * CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) END IF * BETA = LBETA T = LT RND = LRND EPS = LEPS EMIN = LEMIN RMIN = LRMIN EMAX = LEMAX RMAX = LRMAX * RETURN * 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', $ ' EMIN = ', I8, / $ ' If, after inspection, the value EMIN looks', $ ' acceptable please comment out ', $ / ' the IF block as marked within the code of routine', $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) * * End of DLAMC2 * END * ************************************************************************ * DOUBLE PRECISION FUNCTION DLAMC3( A, B ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION A, B * .. * * Purpose * ======= * * DLAMC3 is intended to force A and B to be stored prior to doing * the addition of A and B , for use in situations where optimizers * might hold one of these in a register. * * Arguments * ========= * * A, B (input) DOUBLE PRECISION * The values A and B. * * ===================================================================== * * .. Executable Statements .. * DLAMC3 = A + B * RETURN * * End of DLAMC3 * END * ************************************************************************ * SUBROUTINE DLAMC4( EMIN, START, BASE ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER BASE, EMIN DOUBLE PRECISION START * .. * * Purpose * ======= * * DLAMC4 is a service routine for DLAMC2. * * Arguments * ========= * * EMIN (output) EMIN * The minimum exponent before (gradual) underflow, computed by * setting A = START and dividing by BASE until the previous A * can not be recovered. * * START (input) DOUBLE PRECISION * The starting point for determining EMIN. * * BASE (input) INTEGER * The base of the machine. * * ===================================================================== * * .. Local Scalars .. INTEGER I DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO * .. * .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 * .. * .. Executable Statements .. * A = START ONE = 1 RBASE = ONE / BASE ZERO = 0 EMIN = 1 B1 = DLAMC3( A*RBASE, ZERO ) C1 = A C2 = A D1 = A D2 = A *+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. * $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP 10 CONTINUE IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. $ ( D2.EQ.A ) ) THEN EMIN = EMIN - 1 A = B1 B1 = DLAMC3( A / BASE, ZERO ) C1 = DLAMC3( B1*BASE, ZERO ) D1 = ZERO DO 20 I = 1, BASE D1 = D1 + B1 20 CONTINUE B2 = DLAMC3( A*RBASE, ZERO ) C2 = DLAMC3( B2 / RBASE, ZERO ) D2 = ZERO DO 30 I = 1, BASE D2 = D2 + B2 30 CONTINUE GO TO 10 END IF *+ END WHILE * RETURN * * End of DLAMC4 * END * ************************************************************************ * SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL IEEE INTEGER BETA, EMAX, EMIN, P DOUBLE PRECISION RMAX * .. * * Purpose * ======= * * DLAMC5 attempts to compute RMAX, the largest machine floating-point * number, without overflow. It assumes that EMAX + abs(EMIN) sum * approximately to a power of 2. It will fail on machines where this * assumption does not hold, for example, the Cyber 205 (EMIN = -28625, * EMAX = 28718). It will also fail if the value supplied for EMIN is * too large (i.e. too close to zero), probably with overflow. * * Arguments * ========= * * BETA (input) INTEGER * The base of floating-point arithmetic. * * P (input) INTEGER * The number of base BETA digits in the mantissa of a * floating-point value. * * EMIN (input) INTEGER * The minimum exponent before (gradual) underflow. * * IEEE (input) LOGICAL * A logical flag specifying whether or not the arithmetic * system is thought to comply with the IEEE standard. * * EMAX (output) INTEGER * The largest exponent before overflow * * RMAX (output) DOUBLE PRECISION * The largest machine floating-point number. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP DOUBLE PRECISION OLDY, RECBAS, Y, Z * .. * .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. * .. Executable Statements .. * * First compute LEXP and UEXP, two powers of 2 that bound * abs(EMIN). We then assume that EMAX + abs(EMIN) will sum * approximately to the bound that is closest to abs(EMIN). * (EMAX is the exponent of the required number RMAX). * LEXP = 1 EXBITS = 1 10 CONTINUE TRY = LEXP*2 IF( TRY.LE.( -EMIN ) ) THEN LEXP = TRY EXBITS = EXBITS + 1 GO TO 10 END IF IF( LEXP.EQ.-EMIN ) THEN UEXP = LEXP ELSE UEXP = TRY EXBITS = EXBITS + 1 END IF * * Now -LEXP is less than or equal to EMIN, and -UEXP is greater * than or equal to EMIN. EXBITS is the number of bits needed to * store the exponent. * IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN EXPSUM = 2*LEXP ELSE EXPSUM = 2*UEXP END IF * * EXPSUM is the exponent range, approximately equal to * EMAX - EMIN + 1 . * EMAX = EXPSUM + EMIN - 1 NBITS = 1 + EXBITS + P * * NBITS is the total number of bits needed to store a * floating-point number. * IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN * * Either there are an odd number of bits used to store a * floating-point number, which is unlikely, or some bits are * not used in the representation of numbers, which is possible, * (e.g. Cray machines) or the mantissa has an implicit bit, * (e.g. IEEE machines, Dec Vax machines), which is perhaps the * most likely. We have to assume the last alternative. * If this is true, then we need to reduce EMAX by one because * there must be some way of representing zero in an implicit-bit * system. On machines like Cray, we are reducing EMAX by one * unnecessarily. * EMAX = EMAX - 1 END IF * IF( IEEE ) THEN * * Assume we are on an IEEE machine which reserves one exponent * for infinity and NaN. * EMAX = EMAX - 1 END IF * * Now create RMAX, the largest machine number, which should * be equal to (1.0 - BETA**(-P)) * BETA**EMAX . * * First compute 1.0 - BETA**(-P), being careful that the * result is less than 1.0 . * RECBAS = ONE / BETA Z = BETA - ONE Y = ZERO DO 20 I = 1, P Z = Z*RECBAS IF( Y.LT.ONE ) $ OLDY = Y Y = DLAMC3( Y, Z ) 20 CONTINUE IF( Y.GE.ONE ) $ Y = OLDY * * Now multiply by BETA**EMAX to get RMAX. * DO 30 I = 1, EMAX Y = DLAMC3( Y*BETA, ZERO ) 30 CONTINUE * RMAX = Y RETURN * * End of DLAMC5 * END DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * DLANGE returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * real matrix A. * * Description * =========== * * DLANGE returns the value * * DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in DLANGE as described * above. * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. When M = 0, * DLANGE is set to zero. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. When N = 0, * DLANGE is set to zero. * * A (input) DOUBLE PRECISION array, dimension (LDA,N) * The m by n matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( MIN( M, N ).EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, M VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, M SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE VALUE = MAX( VALUE, SUM ) 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, M WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, M VALUE = MAX( VALUE, WORK( I ) ) 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL DLASSQ( M, A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * DLANGE = VALUE RETURN * * End of DLANGE * END DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * DLANHS returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * Hessenberg matrix A. * * Description * =========== * * DLANHS returns the value * * DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in DLANHS as described * above. * * N (input) INTEGER * The order of the matrix A. N >= 0. When N = 0, DLANHS is * set to zero. * * A (input) DOUBLE PRECISION array, dimension (LDA,N) * The n by n upper Hessenberg matrix A; the part of A below the * first sub-diagonal is not referenced. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= N when NORM = 'I'; otherwise, WORK is not * referenced. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, MIN( N, J+1 ) VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, MIN( N, J+1 ) SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE VALUE = MAX( VALUE, SUM ) 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, N WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, MIN( N, J+1 ) WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, N VALUE = MAX( VALUE, WORK( I ) ) 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL DLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * DLANHS = VALUE RETURN * * End of DLANHS * END SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) * * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN * .. * * Purpose * ======= * * DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric * matrix in standard form: * * [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] * [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] * * where either * 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or * 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex * conjugate eigenvalues. * * Arguments * ========= * * A (input/output) DOUBLE PRECISION * B (input/output) DOUBLE PRECISION * C (input/output) DOUBLE PRECISION * D (input/output) DOUBLE PRECISION * On entry, the elements of the input matrix. * On exit, they are overwritten by the elements of the * standardised Schur form. * * RT1R (output) DOUBLE PRECISION * RT1I (output) DOUBLE PRECISION * RT2R (output) DOUBLE PRECISION * RT2I (output) DOUBLE PRECISION * The real and imaginary parts of the eigenvalues. If the * eigenvalues are a complex conjugate pair, RT1I > 0. * * CS (output) DOUBLE PRECISION * SN (output) DOUBLE PRECISION * Parameters of the rotation matrix. * * Further Details * =============== * * Modified by V. Sima, Research Institute for Informatics, Bucharest, * Romania, to reduce the risk of cancellation errors, * when computing real eigenvalues, and to ensure, if possible, that * abs(RT1R) >= abs(RT2R). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) DOUBLE PRECISION MULTPL PARAMETER ( MULTPL = 4.0D+0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB, $ SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL DLAMCH, DLAPY2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SIGN, SQRT * .. * .. Executable Statements .. * EPS = DLAMCH( 'P' ) IF( C.EQ.ZERO ) THEN CS = ONE SN = ZERO GO TO 10 * ELSE IF( B.EQ.ZERO ) THEN * * Swap rows and columns * CS = ZERO SN = ONE TEMP = D D = A A = TEMP B = -C C = ZERO GO TO 10 ELSE IF( ( A-D ).EQ.ZERO .AND. SIGN( ONE, B ).NE.SIGN( ONE, C ) ) $ THEN CS = ONE SN = ZERO GO TO 10 ELSE * TEMP = A - D P = HALF*TEMP BCMAX = MAX( ABS( B ), ABS( C ) ) BCMIS = MIN( ABS( B ), ABS( C ) )*SIGN( ONE, B )*SIGN( ONE, C ) SCALE = MAX( ABS( P ), BCMAX ) Z = ( P / SCALE )*P + ( BCMAX / SCALE )*BCMIS * * If Z is of the order of the machine accuracy, postpone the * decision on the nature of eigenvalues * IF( Z.GE.MULTPL*EPS ) THEN * * Real eigenvalues. Compute A and D. * Z = P + SIGN( SQRT( SCALE )*SQRT( Z ), P ) A = D + Z D = D - ( BCMAX / Z )*BCMIS * * Compute B and the rotation matrix * TAU = DLAPY2( C, Z ) CS = Z / TAU SN = C / TAU B = B - C C = ZERO ELSE * * Complex eigenvalues, or real (almost) equal eigenvalues. * Make diagonal elements equal. * SIGMA = B + C TAU = DLAPY2( SIGMA, TEMP ) CS = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) ) SN = -( P / ( TAU*CS ) )*SIGN( ONE, SIGMA ) * * Compute [ AA BB ] = [ A B ] [ CS -SN ] * [ CC DD ] [ C D ] [ SN CS ] * AA = A*CS + B*SN BB = -A*SN + B*CS CC = C*CS + D*SN DD = -C*SN + D*CS * * Compute [ A B ] = [ CS SN ] [ AA BB ] * [ C D ] [-SN CS ] [ CC DD ] * A = AA*CS + CC*SN B = BB*CS + DD*SN C = -AA*SN + CC*CS D = -BB*SN + DD*CS * TEMP = HALF*( A+D ) A = TEMP D = TEMP * IF( C.NE.ZERO ) THEN IF( B.NE.ZERO ) THEN IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN * * Real eigenvalues: reduce to upper triangular form * SAB = SQRT( ABS( B ) ) SAC = SQRT( ABS( C ) ) P = SIGN( SAB*SAC, C ) TAU = ONE / SQRT( ABS( B+C ) ) A = TEMP + P D = TEMP - P B = B - C C = ZERO CS1 = SAB*TAU SN1 = SAC*TAU TEMP = CS*CS1 - SN*SN1 SN = CS*SN1 + SN*CS1 CS = TEMP END IF ELSE B = -C C = ZERO TEMP = CS CS = -SN SN = TEMP END IF END IF END IF * END IF * 10 CONTINUE * * Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). * RT1R = A RT2R = D IF( C.EQ.ZERO ) THEN RT1I = ZERO RT2I = ZERO ELSE RT1I = SQRT( ABS( B ) )*SQRT( ABS( C ) ) RT2I = -RT1I END IF RETURN * * End of DLANV2 * END DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y * .. * * Purpose * ======= * * DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary * overflow. * * Arguments * ========= * * X (input) DOUBLE PRECISION * Y (input) DOUBLE PRECISION * X and Y specify the values x and y. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION W, XABS, YABS, Z * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * XABS = ABS( X ) YABS = ABS( Y ) W = MAX( XABS, YABS ) Z = MIN( XABS, YABS ) IF( Z.EQ.ZERO ) THEN DLAPY2 = W ELSE DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) END IF RETURN * * End of DLAPY2 * END SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, LDC, M, N DOUBLE PRECISION TAU * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * Purpose * ======= * * DLARF applies a real elementary reflector H to a real m by n matrix * C, from either the left or the right. H is represented in the form * * H = I - tau * v * v' * * where tau is a real scalar and v is a real vector. * * If tau = 0, then H is taken to be the unit matrix. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': form H * C * = 'R': form C * H * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * V (input) DOUBLE PRECISION array, dimension * (1 + (M-1)*abs(INCV)) if SIDE = 'L' * or (1 + (N-1)*abs(INCV)) if SIDE = 'R' * The vector v in the representation of H. V is not used if * TAU = 0. * * INCV (input) INTEGER * The increment between elements of v. INCV <> 0. * * TAU (input) DOUBLE PRECISION * The value tau in the representation of H. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by the matrix H * C if SIDE = 'L', * or C * H if SIDE = 'R'. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) DOUBLE PRECISION array, dimension * (N) if SIDE = 'L' * or (M) if SIDE = 'R' * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. External Subroutines .. EXTERNAL DGEMV, DGER * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C * IF( TAU.NE.ZERO ) THEN * * w := C' * v * CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO, $ WORK, 1 ) * * C := C - v * w' * CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) END IF ELSE * * Form C * H * IF( TAU.NE.ZERO ) THEN * * w := C * v * CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, $ ZERO, WORK, 1 ) * * C := C - w * v' * CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) END IF END IF RETURN * * End of DLARF * END SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS INTEGER K, LDC, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), $ WORK( LDWORK, * ) * .. * * Purpose * ======= * * DLARFB applies a real block reflector H or its transpose H' to a * real m by n matrix C, from either the left or the right. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply H or H' from the Left * = 'R': apply H or H' from the Right * * TRANS (input) CHARACTER*1 * = 'N': apply H (No transpose) * = 'T': apply H' (Transpose) * * DIRECT (input) CHARACTER*1 * Indicates how H is formed from a product of elementary * reflectors * = 'F': H = H(1) H(2) . . . H(k) (Forward) * = 'B': H = H(k) . . . H(2) H(1) (Backward) * * STOREV (input) CHARACTER*1 * Indicates how the vectors which define the elementary * reflectors are stored: * = 'C': Columnwise * = 'R': Rowwise * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * K (input) INTEGER * The order of the matrix T (= the number of elementary * reflectors whose product defines the block reflector). * * V (input) DOUBLE PRECISION array, dimension * (LDV,K) if STOREV = 'C' * (LDV,M) if STOREV = 'R' and SIDE = 'L' * (LDV,N) if STOREV = 'R' and SIDE = 'R' * The matrix V. See further details. * * LDV (input) INTEGER * The leading dimension of the array V. * If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); * if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); * if STOREV = 'R', LDV >= K. * * T (input) DOUBLE PRECISION array, dimension (LDT,K) * The triangular k by k matrix T in the representation of the * block reflector. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= K. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by H*C or H'*C or C*H or C*H'. * * LDC (input) INTEGER * The leading dimension of the array C. LDA >= max(1,M). * * WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) * * LDWORK (input) INTEGER * The leading dimension of the array WORK. * If SIDE = 'L', LDWORK >= max(1,N); * if SIDE = 'R', LDWORK >= max(1,M). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. CHARACTER TRANST INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DTRMM * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * IF( LSAME( TRANS, 'N' ) ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF * IF( LSAME( STOREV, 'C' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 ) (first K rows) * ( V2 ) * where V1 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) * * W := C1' * DO 10 J = 1, K CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 10 CONTINUE * * W := W * V1 * CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2'*V2 * CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T' or W * T * CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W' * IF( M.GT.K ) THEN * * C2 := C2 - V2 * W' * CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, $ C( K+1, 1 ), LDC ) END IF * * W := W * V1' * CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W' * DO 30 J = 1, K DO 20 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 20 CONTINUE 30 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, $ K, ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2 * CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T' * CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V' * IF( N.GT.K ) THEN * * C2 := C2 - W * V2' * CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, $ C( 1, K+1 ), LDC ) END IF * * W := W * V1' * CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE END IF * ELSE * * Let V = ( V1 ) * ( V2 ) (last K rows) * where V2 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) * * W := C2' * DO 70 J = 1, K CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1'*V1 * CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T' or W * T * CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W' * IF( M.GT.K ) THEN * * C1 := C1 - V1 * W' * CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2' * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W' * DO 90 J = 1, K DO 80 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 80 CONTINUE 90 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T' * CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V' * IF( N.GT.K ) THEN * * C1 := C1 - W * V1' * CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2' * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K DO 110 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF END IF * ELSE IF( LSAME( STOREV, 'R' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 V2 ) (V1: first K columns) * where V1 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) * * W := C1' * DO 130 J = 1, K CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1' * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, $ ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2'*V2' * CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, $ WORK, LDWORK ) END IF * * W := W * T' or W * T * CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V' * W' * IF( M.GT.K ) THEN * * C2 := C2 - V2' * W' * CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, $ C( K+1, 1 ), LDC ) END IF * * W := W * V1 * CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W' * DO 150 J = 1, K DO 140 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 140 CONTINUE 150 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V' = (C1*V1' + C2*V2') (stored in WORK) * * W := C1 * DO 160 J = 1, K CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1' * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, $ ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2' * CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T' * CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, $ C( 1, K+1 ), LDC ) END IF * * W := W * V1 * CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE * END IF * ELSE * * Let V = ( V1 V2 ) (V2: last K columns) * where V2 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) * * W := C2' * DO 190 J = 1, K CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2' * CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1'*V1' * CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T' or W * T * CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V' * W' * IF( M.GT.K ) THEN * * C1 := C1 - V1' * W' * CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, $ V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2 * CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W' * DO 210 J = 1, K DO 200 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 200 CONTINUE 210 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V' = (C1*V1' + C2*V2') (stored in WORK) * * W := C2 * DO 220 J = 1, K CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2' * CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1' * CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T' * CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C1 := C1 - W * V1 * CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2 * CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K DO 230 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE * END IF * END IF END IF * RETURN * * End of DLARFB * END SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION ALPHA, TAU * .. * .. Array Arguments .. DOUBLE PRECISION X( * ) * .. * * Purpose * ======= * * DLARFG generates a real elementary reflector H of order n, such * that * * H * ( alpha ) = ( beta ), H' * H = I. * ( x ) ( 0 ) * * where alpha and beta are scalars, and x is an (n-1)-element real * vector. H is represented in the form * * H = I - tau * ( 1 ) * ( 1 v' ) , * ( v ) * * where tau is a real scalar and v is a real (n-1)-element * vector. * * If the elements of x are all zero, then tau = 0 and H is taken to be * the unit matrix. * * Otherwise 1 <= tau <= 2. * * Arguments * ========= * * N (input) INTEGER * The order of the elementary reflector. * * ALPHA (input/output) DOUBLE PRECISION * On entry, the value alpha. * On exit, it is overwritten with the value beta. * * X (input/output) DOUBLE PRECISION array, dimension * (1+(N-2)*abs(INCX)) * On entry, the vector x. * On exit, it is overwritten with the vector v. * * INCX (input) INTEGER * The increment between elements of X. INCX > 0. * * TAU (output) DOUBLE PRECISION * The value tau. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER J, KNT DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 EXTERNAL DLAMCH, DLAPY2, DNRM2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN * .. * .. External Subroutines .. EXTERNAL DSCAL * .. * .. Executable Statements .. * IF( N.LE.1 ) THEN TAU = ZERO RETURN END IF * XNORM = DNRM2( N-1, X, INCX ) * IF( XNORM.EQ.ZERO ) THEN * * H = I * TAU = ZERO ELSE * * general case * BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) IF( ABS( BETA ).LT.SAFMIN ) THEN * * XNORM, BETA may be inaccurate; scale X and recompute them * RSAFMN = ONE / SAFMIN KNT = 0 10 CONTINUE KNT = KNT + 1 CALL DSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA*RSAFMN ALPHA = ALPHA*RSAFMN IF( ABS( BETA ).LT.SAFMIN ) $ GO TO 10 * * New BETA is at most 1, at least SAFMIN * XNORM = DNRM2( N-1, X, INCX ) BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) TAU = ( BETA-ALPHA ) / BETA CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) * * If ALPHA is subnormal, it may lose relative accuracy * ALPHA = BETA DO 20 J = 1, KNT ALPHA = ALPHA*SAFMIN 20 CONTINUE ELSE TAU = ( BETA-ALPHA ) / BETA CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) ALPHA = BETA END IF END IF * RETURN * * End of DLARFG * END SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * Purpose * ======= * * DLARFT forms the triangular factor T of a real block reflector H * of order n, which is defined as a product of k elementary reflectors. * * If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; * * If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. * * If STOREV = 'C', the vector which defines the elementary reflector * H(i) is stored in the i-th column of the array V, and * * H = I - V * T * V' * * If STOREV = 'R', the vector which defines the elementary reflector * H(i) is stored in the i-th row of the array V, and * * H = I - V' * T * V * * Arguments * ========= * * DIRECT (input) CHARACTER*1 * Specifies the order in which the elementary reflectors are * multiplied to form the block reflector: * = 'F': H = H(1) H(2) . . . H(k) (Forward) * = 'B': H = H(k) . . . H(2) H(1) (Backward) * * STOREV (input) CHARACTER*1 * Specifies how the vectors which define the elementary * reflectors are stored (see also Further Details): * = 'C': columnwise * = 'R': rowwise * * N (input) INTEGER * The order of the block reflector H. N >= 0. * * K (input) INTEGER * The order of the triangular factor T (= the number of * elementary reflectors). K >= 1. * * V (input/output) DOUBLE PRECISION array, dimension * (LDV,K) if STOREV = 'C' * (LDV,N) if STOREV = 'R' * The matrix V. See further details. * * LDV (input) INTEGER * The leading dimension of the array V. * If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. * * TAU (input) DOUBLE PRECISION array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i). * * T (output) DOUBLE PRECISION array, dimension (LDT,K) * The k by k triangular factor T of the block reflector. * If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is * lower triangular. The rest of the array is not used. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= K. * * Further Details * =============== * * The shape of the matrix V and the storage of the vectors which define * the H(i) is best illustrated by the following example with n = 5 and * k = 3. The elements equal to 1 are not stored; the corresponding * array elements are modified but restored on exit. The rest of the * array is not used. * * DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': * * V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) * ( v1 1 ) ( 1 v2 v2 v2 ) * ( v1 v2 1 ) ( 1 v3 v3 ) * ( v1 v2 v3 ) * ( v1 v2 v3 ) * * DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': * * V = ( v1 v2 v3 ) V = ( v1 v1 1 ) * ( v1 v2 v3 ) ( v2 v2 v2 1 ) * ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) * ( 1 v3 ) * ( 1 ) * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION VII * .. * .. External Subroutines .. EXTERNAL DGEMV, DTRMV * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( LSAME( DIRECT, 'F' ) ) THEN DO 20 I = 1, K IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO 10 J = 1, I T( J, I ) = ZERO 10 CONTINUE ELSE * * general case * VII = V( I, I ) V( I, I ) = ONE IF( LSAME( STOREV, 'C' ) ) THEN * * T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) * CALL DGEMV( 'Transpose', N-I+1, I-1, -TAU( I ), $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, $ T( 1, I ), 1 ) ELSE * * T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' * CALL DGEMV( 'No transpose', I-1, N-I+1, -TAU( I ), $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, $ T( 1, I ), 1 ) END IF V( I, I ) = VII * * T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) * CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, $ LDT, T( 1, I ), 1 ) T( I, I ) = TAU( I ) END IF 20 CONTINUE ELSE DO 40 I = K, 1, -1 IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO 30 J = I, K T( J, I ) = ZERO 30 CONTINUE ELSE * * general case * IF( I.LT.K ) THEN IF( LSAME( STOREV, 'C' ) ) THEN VII = V( N-K+I, I ) V( N-K+I, I ) = ONE * * T(i+1:k,i) := * - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) * CALL DGEMV( 'Transpose', N-K+I, K-I, -TAU( I ), $ V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO, $ T( I+1, I ), 1 ) V( N-K+I, I ) = VII ELSE VII = V( I, N-K+I ) V( I, N-K+I ) = ONE * * T(i+1:k,i) := * - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' * CALL DGEMV( 'No transpose', K-I, N-K+I, -TAU( I ), $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, $ T( I+1, I ), 1 ) V( I, N-K+I ) = VII END IF * * T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) * CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) END IF T( I, I ) = TAU( I ) END IF 40 CONTINUE END IF RETURN * * End of DLARFT * END SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER LDC, M, N DOUBLE PRECISION TAU * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * Purpose * ======= * * DLARFX applies a real elementary reflector H to a real m by n * matrix C, from either the left or the right. H is represented in the * form * * H = I - tau * v * v' * * where tau is a real scalar and v is a real vector. * * If tau = 0, then H is taken to be the unit matrix * * This version uses inline code if H has order < 11. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': form H * C * = 'R': form C * H * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * V (input) DOUBLE PRECISION array, dimension (M) if SIDE = 'L' * or (N) if SIDE = 'R' * The vector v in the representation of H. * * TAU (input) DOUBLE PRECISION * The value tau in the representation of H. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by the matrix H * C if SIDE = 'L', * or C * H if SIDE = 'R'. * * LDC (input) INTEGER * The leading dimension of the array C. LDA >= (1,M). * * WORK (workspace) DOUBLE PRECISION array, dimension * (N) if SIDE = 'L' * or (M) if SIDE = 'R' * WORK is not referenced if H has order < 11. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER J DOUBLE PRECISION SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9 * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DGEMV, DGER * .. * .. Executable Statements .. * IF( TAU.EQ.ZERO ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C, where H has order m. * GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, $ 170, 190 )M * * Code for general M * * w := C'*v * CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, 1, ZERO, WORK, $ 1 ) * * C := C - tau * v * w' * CALL DGER( M, N, -TAU, V, 1, WORK, 1, C, LDC ) GO TO 410 10 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*V( 1 ) DO 20 J = 1, N C( 1, J ) = T1*C( 1, J ) 20 CONTINUE GO TO 410 30 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 DO 40 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 40 CONTINUE GO TO 410 50 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 DO 60 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 60 CONTINUE GO TO 410 70 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 DO 80 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 80 CONTINUE GO TO 410 90 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 DO 100 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 100 CONTINUE GO TO 410 110 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 DO 120 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 120 CONTINUE GO TO 410 130 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 DO 140 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 140 CONTINUE GO TO 410 150 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 DO 160 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 160 CONTINUE GO TO 410 170 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 DO 180 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 180 CONTINUE GO TO 410 190 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 V10 = V( 10 ) T10 = TAU*V10 DO 200 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + $ V10*C( 10, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 C( 10, J ) = C( 10, J ) - SUM*T10 200 CONTINUE GO TO 410 ELSE * * Form C * H, where H has order n. * GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, $ 370, 390 )N * * Code for general N * * w := C * v * CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO, $ WORK, 1 ) * * C := C - tau * w * v' * CALL DGER( M, N, -TAU, WORK, 1, V, 1, C, LDC ) GO TO 410 210 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*V( 1 ) DO 220 J = 1, M C( J, 1 ) = T1*C( J, 1 ) 220 CONTINUE GO TO 410 230 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 DO 240 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 240 CONTINUE GO TO 410 250 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 DO 260 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 260 CONTINUE GO TO 410 270 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 DO 280 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 280 CONTINUE GO TO 410 290 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 DO 300 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 300 CONTINUE GO TO 410 310 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 DO 320 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 320 CONTINUE GO TO 410 330 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 DO 340 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 340 CONTINUE GO TO 410 350 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 DO 360 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 360 CONTINUE GO TO 410 370 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 DO 380 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 380 CONTINUE GO TO 410 390 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 V10 = V( 10 ) T10 = TAU*V10 DO 400 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + $ V10*C( J, 10 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 C( J, 10 ) = C( J, 10 ) - SUM*T10 400 CONTINUE GO TO 410 END IF 410 CONTINUE RETURN * * End of DLARFX * END SUBROUTINE DLARTG( F, G, CS, SN, R ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. DOUBLE PRECISION CS, F, G, R, SN * .. * * Purpose * ======= * * DLARTG generate a plane rotation so that * * [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. * [ -SN CS ] [ G ] [ 0 ] * * This is a slower, more accurate version of the BLAS1 routine DROTG, * with the following other differences: * F and G are unchanged on return. * If G=0, then CS=1 and SN=0. * If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any * floating point operations (saves work in DBDSQR when * there are zeros on the diagonal). * * If F exceeds G in magnitude, CS will be positive. * * Arguments * ========= * * F (input) DOUBLE PRECISION * The first component of vector to be rotated. * * G (input) DOUBLE PRECISION * The second component of vector to be rotated. * * CS (output) DOUBLE PRECISION * The cosine of the rotation. * * SN (output) DOUBLE PRECISION * The sine of the rotation. * * R (output) DOUBLE PRECISION * The nonzero component of the rotated vector. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) * .. * .. Local Scalars .. LOGICAL FIRST INTEGER COUNT, I DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX, SQRT * .. * .. Save statement .. SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 * .. * .. Data statements .. DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'E' ) SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( DLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 END IF IF( G.EQ.ZERO ) THEN CS = ONE SN = ZERO R = F ELSE IF( F.EQ.ZERO ) THEN CS = ZERO SN = ONE R = G ELSE F1 = F G1 = G SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.GE.SAFMX2 ) THEN COUNT = 0 10 CONTINUE COUNT = COUNT + 1 F1 = F1*SAFMN2 G1 = G1*SAFMN2 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.GE.SAFMX2 ) $ GO TO 10 R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R DO 20 I = 1, COUNT R = R*SAFMX2 20 CONTINUE ELSE IF( SCALE.LE.SAFMN2 ) THEN COUNT = 0 30 CONTINUE COUNT = COUNT + 1 F1 = F1*SAFMX2 G1 = G1*SAFMX2 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.LE.SAFMN2 ) $ GO TO 30 R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R DO 40 I = 1, COUNT R = R*SAFMN2 40 CONTINUE ELSE R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R END IF IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN CS = -CS SN = -SN R = -R END IF END IF RETURN * * End of DLARTG * END SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER TYPE INTEGER INFO, KL, KU, LDA, M, N DOUBLE PRECISION CFROM, CTO * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * Purpose * ======= * * DLASCL multiplies the M by N real matrix A by the real scalar * CTO/CFROM. This is done without over/underflow as long as the final * result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that * A may be full, upper triangular, lower triangular, upper Hessenberg, * or banded. * * Arguments * ========= * * TYPE (input) CHARACTER*1 * TYPE indices the storage type of the input matrix. * = 'G': A is a full matrix. * = 'L': A is a lower triangular matrix. * = 'U': A is an upper triangular matrix. * = 'H': A is an upper Hessenberg matrix. * = 'B': A is a symmetric band matrix with lower bandwidth KL * and upper bandwidth KU and with the only the lower * half stored. * = 'Q': A is a symmetric band matrix with lower bandwidth KL * and upper bandwidth KU and with the only the upper * half stored. * = 'Z': A is a band matrix with lower bandwidth KL and upper * bandwidth KU. * * KL (input) INTEGER * The lower bandwidth of A. Referenced only if TYPE = 'B', * 'Q' or 'Z'. * * KU (input) INTEGER * The upper bandwidth of A. Referenced only if TYPE = 'B', * 'Q' or 'Z'. * * CFROM (input) DOUBLE PRECISION * CTO (input) DOUBLE PRECISION * The matrix A is multiplied by CTO/CFROM. A(I,J) is computed * without over/underflow if the final result CTO*A(I,J)/CFROM * can be represented without over/underflow. CFROM must be * nonzero. * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,M) * The matrix to be multiplied by CTO/CFROM. See TYPE for the * storage type. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * INFO (output) INTEGER * 0 - successful exit * <0 - if INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL DONE INTEGER I, ITYPE, J, K1, K2, K3, K4 DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 * IF( LSAME( TYPE, 'G' ) ) THEN ITYPE = 0 ELSE IF( LSAME( TYPE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( TYPE, 'U' ) ) THEN ITYPE = 2 ELSE IF( LSAME( TYPE, 'H' ) ) THEN ITYPE = 3 ELSE IF( LSAME( TYPE, 'B' ) ) THEN ITYPE = 4 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN ITYPE = 5 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN ITYPE = 6 ELSE ITYPE = -1 END IF * IF( ITYPE.EQ.-1 ) THEN INFO = -1 ELSE IF( CFROM.EQ.ZERO ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN INFO = -7 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( ITYPE.GE.4 ) THEN IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN INFO = -2 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) $ THEN INFO = -3 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN INFO = -9 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASCL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM * CFROMC = CFROM CTOC = CTO * 10 CONTINUE CFROM1 = CFROMC*SMLNUM CTO1 = CTOC / BIGNUM IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN MUL = SMLNUM DONE = .FALSE. CFROMC = CFROM1 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN MUL = BIGNUM DONE = .FALSE. CTOC = CTO1 ELSE MUL = CTOC / CFROMC DONE = .TRUE. END IF * IF( ITYPE.EQ.0 ) THEN * * Full matrix * DO 30 J = 1, N DO 20 I = 1, M A( I, J ) = A( I, J )*MUL 20 CONTINUE 30 CONTINUE * ELSE IF( ITYPE.EQ.1 ) THEN * * Lower triangular matrix * DO 50 J = 1, N DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE 50 CONTINUE * ELSE IF( ITYPE.EQ.2 ) THEN * * Upper triangular matrix * DO 70 J = 1, N DO 60 I = 1, MIN( J, M ) A( I, J ) = A( I, J )*MUL 60 CONTINUE 70 CONTINUE * ELSE IF( ITYPE.EQ.3 ) THEN * * Upper Hessenberg matrix * DO 90 J = 1, N DO 80 I = 1, MIN( J+1, M ) A( I, J ) = A( I, J )*MUL 80 CONTINUE 90 CONTINUE * ELSE IF( ITYPE.EQ.4 ) THEN * * Lower half of a symmetric band matrix * K3 = KL + 1 K4 = N + 1 DO 110 J = 1, N DO 100 I = 1, MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 100 CONTINUE 110 CONTINUE * ELSE IF( ITYPE.EQ.5 ) THEN * * Upper half of a symmetric band matrix * K1 = KU + 2 K3 = KU + 1 DO 130 J = 1, N DO 120 I = MAX( K1-J, 1 ), K3 A( I, J ) = A( I, J )*MUL 120 CONTINUE 130 CONTINUE * ELSE IF( ITYPE.EQ.6 ) THEN * * Band matrix * K1 = KL + KU + 2 K2 = KL + 1 K3 = 2*KL + KU + 1 K4 = KL + KU + 1 + M DO 150 J = 1, N DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 140 CONTINUE 150 CONTINUE * END IF * IF( .NOT.DONE ) $ GO TO 10 * RETURN * * End of DLASCL * END SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, M, N DOUBLE PRECISION ALPHA, BETA * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * Purpose * ======= * * DLASET initializes an m-by-n matrix A to BETA on the diagonal and * ALPHA on the offdiagonals. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies the part of the matrix A to be set. * = 'U': Upper triangular part is set; the strictly lower * triangular part of A is not changed. * = 'L': Lower triangular part is set; the strictly upper * triangular part of A is not changed. * Otherwise: All of the matrix A is set. * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * ALPHA (input) DOUBLE PRECISION * The constant to which the offdiagonal elements are to be set. * * BETA (input) DOUBLE PRECISION * The constant to which the diagonal elements are to be set. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On exit, the leading m-by-n submatrix of A is set as follows: * * if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, * if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, * otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, * * and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN * * Set the strictly upper triangular or trapezoidal part of the * array to ALPHA. * DO 20 J = 2, N DO 10 I = 1, MIN( J-1, M ) A( I, J ) = ALPHA 10 CONTINUE 20 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN * * Set the strictly lower triangular or trapezoidal part of the * array to ALPHA. * DO 40 J = 1, MIN( M, N ) DO 30 I = J + 1, M A( I, J ) = ALPHA 30 CONTINUE 40 CONTINUE * ELSE * * Set the leading m-by-n submatrix to ALPHA. * DO 60 J = 1, N DO 50 I = 1, M A( I, J ) = ALPHA 50 CONTINUE 60 CONTINUE END IF * * Set the first min(M,N) diagonal elements to BETA. * DO 70 I = 1, MIN( M, N ) A( I, I ) = BETA 70 CONTINUE * RETURN * * End of DLASET * END SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION SCALE, SUMSQ * .. * .. Array Arguments .. DOUBLE PRECISION X( * ) * .. * * Purpose * ======= * * DLASSQ returns the values scl and smsq such that * * ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, * * where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is * assumed to be non-negative and scl returns the value * * scl = max( scale, abs( x( i ) ) ). * * scale and sumsq must be supplied in SCALE and SUMSQ and * scl and smsq are overwritten on SCALE and SUMSQ respectively. * * The routine makes only one pass through the vector x. * * Arguments * ========= * * N (input) INTEGER * The number of elements to be used from the vector X. * * X (input) DOUBLE PRECISION array, dimension (N) * The vector for which a scaled sum of squares is computed. * x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. * * INCX (input) INTEGER * The increment between successive values of the vector X. * INCX > 0. * * SCALE (input/output) DOUBLE PRECISION * On entry, the value scale in the equation above. * On exit, SCALE is overwritten with scl , the scaling factor * for the sum of squares. * * SUMSQ (input/output) DOUBLE PRECISION * On entry, the value sumsq in the equation above. * On exit, SUMSQ is overwritten with smsq , the basic sum of * squares from which scl has been factored out. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER IX DOUBLE PRECISION ABSXI * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * IF( N.GT.0 ) THEN DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX IF( X( IX ).NE.ZERO ) THEN ABSXI = ABS( X( IX ) ) IF( SCALE.LT.ABSXI ) THEN SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 SCALE = ABSXI ELSE SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 END IF END IF 10 CONTINUE END IF RETURN * * End of DLASSQ * END SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DORG2R generates an m by n real matrix Q with orthonormal columns, * which is defined as the first n columns of a product of k elementary * reflectors of order m * * Q = H(1) H(2) . . . H(k) * * as returned by DGEQRF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. M >= N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. N >= K >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the i-th column must contain the vector which * defines the elementary reflector H(i), for i = 1,2,...,k, as * returned by DGEQRF in the first k columns of its array * argument A. * On exit, the m-by-n matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) DOUBLE PRECISION array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEQRF. * * WORK (workspace) DOUBLE PRECISION array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J, L * .. * .. External Subroutines .. EXTERNAL DLARF, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORG2R', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.0 ) $ RETURN * * Initialise columns k+1:n to columns of the unit matrix * DO 20 J = K + 1, N DO 10 L = 1, M A( L, J ) = ZERO 10 CONTINUE A( J, J ) = ONE 20 CONTINUE * DO 40 I = K, 1, -1 * * Apply H(i) to A(i:m,i:n) from the left * IF( I.LT.N ) THEN A( I, I ) = ONE CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK ) END IF IF( I.LT.M ) $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) A( I, I ) = ONE - TAU( I ) * * Set A(1:i-1,i) to zero * DO 30 L = 1, I - 1 A( L, I ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of DORG2R * END SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DORGHR generates a real orthogonal matrix Q which is defined as the * product of IHI-ILO elementary reflectors of order N, as returned by * DGEHRD: * * Q = H(ilo) H(ilo+1) . . . H(ihi-1). * * Arguments * ========= * * N (input) INTEGER * The order of the matrix Q. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * ILO and IHI must have the same values as in the previous call * of DGEHRD. Q is equal to the unit matrix except in the * submatrix Q(ilo+1:ihi,ilo+1:ihi). * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the vectors which define the elementary reflectors, * as returned by DGEHRD. * On exit, the N-by-N orthogonal matrix Q. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * TAU (input) DOUBLE PRECISION array, dimension (N-1) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEHRD. * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= IHI-ILO. * For optimum performance LWORK >= (IHI-ILO)*NB, where NB is * the optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IINFO, J, LWKOPT, NB, NH * .. * .. External Subroutines .. EXTERNAL DORGQR, XERBLA * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NH = IHI - ILO LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'DORGQR', ' ', NH, NH, NH, -1 ) LWKOPT = MAX( 1, NH )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGHR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * * Shift the vectors which define the elementary reflectors one * column to the right, and set the first ilo and the last n-ihi * rows and columns to those of the unit matrix * DO 40 J = IHI, ILO + 1, -1 DO 10 I = 1, J - 1 A( I, J ) = ZERO 10 CONTINUE DO 20 I = J + 1, IHI A( I, J ) = A( I, J-1 ) 20 CONTINUE DO 30 I = IHI + 1, N A( I, J ) = ZERO 30 CONTINUE 40 CONTINUE DO 60 J = 1, ILO DO 50 I = 1, N A( I, J ) = ZERO 50 CONTINUE A( J, J ) = ONE 60 CONTINUE DO 80 J = IHI + 1, N DO 70 I = 1, N A( I, J ) = ZERO 70 CONTINUE A( J, J ) = ONE 80 CONTINUE * IF( NH.GT.0 ) THEN * * Generate Q(ilo+1:ihi,ilo+1:ihi) * CALL DORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), $ WORK, LWORK, IINFO ) END IF WORK( 1 ) = LWKOPT RETURN * * End of DORGHR * END SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DORGQR generates an M-by-N real matrix Q with orthonormal columns, * which is defined as the first N columns of a product of K elementary * reflectors of order M * * Q = H(1) H(2) . . . H(k) * * as returned by DGEQRF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. M >= N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. N >= K >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the i-th column must contain the vector which * defines the elementary reflector H(i), for i = 1,2,...,k, as * returned by DGEQRF in the first k columns of its array * argument A. * On exit, the M-by-N matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) DOUBLE PRECISION array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEQRF. * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,N). * For optimum performance LWORK >= N*NB, where NB is the * optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) LWKOPT = MAX( 1, N )*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the last block. * The first kk columns are handled by the block method. * KI = ( ( K-NX-1 ) / NB )*NB KK = MIN( K, KI+NB ) * * Set A(1:kk,kk+1:n) to zero. * DO 20 J = KK + 1, N DO 10 I = 1, KK A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the last or only block. * IF( KK.LT.N ) $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, $ TAU( KK+1 ), WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = KI + 1, 1, -NB IB = MIN( NB, K-I+1 ) IF( I+IB.LE.N ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(i:m,i+ib:n) from the left * CALL DLARFB( 'Left', 'No transpose', 'Forward', $ 'Columnwise', M-I+1, N-I-IB+1, IB, $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), $ LDA, WORK( IB+1 ), LDWORK ) END IF * * Apply H to rows i:m of current block * CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * * Set rows 1:i-1 of current block to zero * DO 40 J = I, I + IB - 1 DO 30 L = 1, I - 1 A( L, J ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of DORGQR * END SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE INTEGER INFO, LDT, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), $ WORK( * ) * .. * * Purpose * ======= * * DTREVC computes some or all of the right and/or left eigenvectors of * a real upper quasi-triangular matrix T. * * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: * * T*x = w*x, y'*T = w*y' * * where y' denotes the conjugate transpose of the vector y. * * If all eigenvectors are requested, the routine may either return the * matrices X and/or Y of right or left eigenvectors of T, or the * products Q*X and/or Q*Y, where Q is an input orthogonal * matrix. If T was obtained from the real-Schur factorization of an * original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of * right or left eigenvectors of A. * * T must be in Schur canonical form (as returned by DHSEQR), that is, * block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each * 2-by-2 diagonal block has its diagonal elements equal and its * off-diagonal elements of opposite sign. Corresponding to each 2-by-2 * diagonal block is a complex conjugate pair of eigenvalues and * eigenvectors; only one eigenvector of the pair is computed, namely * the one corresponding to the eigenvalue with positive imaginary part. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'R': compute right eigenvectors only; * = 'L': compute left eigenvectors only; * = 'B': compute both right and left eigenvectors. * * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, * and backtransform them using the input matrices * supplied in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, * specified by the logical array SELECT. * * SELECT (input/output) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. * If HOWMNY = 'A' or 'B', SELECT is not referenced. * To select the real eigenvector corresponding to a real * eigenvalue w(j), SELECT(j) must be set to .TRUE.. To select * the complex eigenvector corresponding to a complex conjugate * pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must be * set to .TRUE.; then on exit SELECT(j) is .TRUE. and * SELECT(j+1) is .FALSE.. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input) DOUBLE PRECISION array, dimension (LDT,N) * The upper quasi-triangular matrix T in Schur canonical form. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must * contain an N-by-N matrix Q (usually the orthogonal matrix Q * of Schur vectors returned by DHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; * VL has the same quasi-lower triangular form * as T'. If T(i,i) is a real eigenvalue, then * the i-th column VL(i) of VL is its * corresponding eigenvector. If T(i:i+1,i:i+1) * is a 2-by-2 block whose eigenvalues are * complex-conjugate eigenvalues of T, then * VL(i)+sqrt(-1)*VL(i+1) is the complex * eigenvector corresponding to the eigenvalue * with positive real part. * if HOWMNY = 'B', the matrix Q*Y; * if HOWMNY = 'S', the left eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VL, in the same order as their * eigenvalues. * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. * If SIDE = 'R', VL is not referenced. * * LDVL (input) INTEGER * The leading dimension of the array VL. LDVL >= max(1,N) if * SIDE = 'L' or 'B'; LDVL >= 1 otherwise. * * VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must * contain an N-by-N matrix Q (usually the orthogonal matrix Q * of Schur vectors returned by DHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; * VR has the same quasi-upper triangular form * as T. If T(i,i) is a real eigenvalue, then * the i-th column VR(i) of VR is its * corresponding eigenvector. If T(i:i+1,i:i+1) * is a 2-by-2 block whose eigenvalues are * complex-conjugate eigenvalues of T, then * VR(i)+sqrt(-1)*VR(i+1) is the complex * eigenvector corresponding to the eigenvalue * with positive real part. * if HOWMNY = 'B', the matrix Q*X; * if HOWMNY = 'S', the right eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VR, in the same order as their * eigenvalues. * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. * If SIDE = 'L', VR is not referenced. * * LDVR (input) INTEGER * The leading dimension of the array VR. LDVR >= max(1,N) if * SIDE = 'R' or 'B'; LDVR >= 1 otherwise. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M. * * M (output) INTEGER * The number of columns in the arrays VL and/or VR actually * used to store the eigenvectors. * If HOWMNY = 'A' or 'B', M is set to N. * Each selected real eigenvector occupies one column and each * selected complex eigenvector occupies two columns. * * WORK (workspace) DOUBLE PRECISION array, dimension (3*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The algorithm used in this program is basically backward (forward) * substitution, with scaling to make the the code robust against * possible overflow. * * Each eigenvector is normalized so that the element of largest * magnitude has magnitude 1; here the magnitude of a complex number * (x,y) is taken to be |x| + |y|. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2 DOUBLE PRECISION BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE, $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR, $ XNORM * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DDOT, DLAMCH EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DLALN2, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Local Arrays .. DOUBLE PRECISION X( 2, 2 ) * .. * .. Executable Statements .. * * Decode and test the input parameters * BOTHV = LSAME( SIDE, 'B' ) RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV * ALLV = LSAME( HOWMNY, 'A' ) OVER = LSAME( HOWMNY, 'B' ) SOMEV = LSAME( HOWMNY, 'S' ) * INFO = 0 IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -1 ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN INFO = -8 ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN INFO = -10 ELSE * * Set M to the number of columns required to store the selected * eigenvectors, standardize the array SELECT if necessary, and * test MM. * IF( SOMEV ) THEN M = 0 PAIR = .FALSE. DO 10 J = 1, N IF( PAIR ) THEN PAIR = .FALSE. SELECT( J ) = .FALSE. ELSE IF( J.LT.N ) THEN IF( T( J+1, J ).EQ.ZERO ) THEN IF( SELECT( J ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN SELECT( J ) = .TRUE. M = M + 2 END IF END IF ELSE IF( SELECT( N ) ) $ M = M + 1 END IF END IF 10 CONTINUE ELSE M = N END IF * IF( MM.LT.M ) THEN INFO = -11 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTREVC', -INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * Set the constants to control overflow. * UNFL = DLAMCH( 'Safe minimum' ) OVFL = ONE / UNFL CALL DLABAD( UNFL, OVFL ) ULP = DLAMCH( 'Precision' ) SMLNUM = UNFL*( N / ULP ) BIGNUM = ( ONE-ULP ) / SMLNUM * * Compute 1-norm of each column of strictly upper triangular * part of T to control overflow in triangular solver. * WORK( 1 ) = ZERO DO 30 J = 2, N WORK( J ) = ZERO DO 20 I = 1, J - 1 WORK( J ) = WORK( J ) + ABS( T( I, J ) ) 20 CONTINUE 30 CONTINUE * * Index IP is used to specify the real or complex eigenvalue: * IP = 0, real eigenvalue, * 1, first of conjugate complex pair: (wr,wi) * -1, second of conjugate complex pair: (wr,wi) * N2 = 2*N * IF( RIGHTV ) THEN * * Compute right eigenvectors. * IP = 0 IS = M DO 140 KI = N, 1, -1 * IF( IP.EQ.1 ) $ GO TO 130 IF( KI.EQ.1 ) $ GO TO 40 IF( T( KI, KI-1 ).EQ.ZERO ) $ GO TO 40 IP = -1 * 40 CONTINUE IF( SOMEV ) THEN IF( IP.EQ.0 ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 130 ELSE IF( .NOT.SELECT( KI-1 ) ) $ GO TO 130 END IF END IF * * Compute the KI-th eigenvalue (WR,WI). * WR = T( KI, KI ) WI = ZERO IF( IP.NE.0 ) $ WI = SQRT( ABS( T( KI, KI-1 ) ) )* $ SQRT( ABS( T( KI-1, KI ) ) ) SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) * IF( IP.EQ.0 ) THEN * * Real right eigenvector * WORK( KI+N ) = ONE * * Form right-hand side * DO 50 K = 1, KI - 1 WORK( K+N ) = -T( K, KI ) 50 CONTINUE * * Solve the upper quasi-triangular system: * (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. * JNXT = KI - 1 DO 60 J = KI - 1, 1, -1 IF( J.GT.JNXT ) $ GO TO 60 J1 = J J2 = J JNXT = J - 1 IF( J.GT.1 ) THEN IF( T( J, J-1 ).NE.ZERO ) THEN J1 = J - 1 JNXT = J - 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale X(1,1) to avoid overflow when updating * the right-hand side. * IF( XNORM.GT.ONE ) THEN IF( WORK( J ).GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) WORK( J+N ) = X( 1, 1 ) * * Update right-hand side * CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) * ELSE * * 2-by-2 diagonal block * CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, $ T( J-1, J-1 ), LDT, ONE, ONE, $ WORK( J-1+N ), N, WR, ZERO, X, 2, $ SCALE, XNORM, IERR ) * * Scale X(1,1) and X(2,1) to avoid overflow when * updating the right-hand side. * IF( XNORM.GT.ONE ) THEN BETA = MAX( WORK( J-1 ), WORK( J ) ) IF( BETA.GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM X( 2, 1 ) = X( 2, 1 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) WORK( J-1+N ) = X( 1, 1 ) WORK( J+N ) = X( 2, 1 ) * * Update right-hand side * CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) END IF 60 CONTINUE * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 ) * II = IDAMAX( KI, VR( 1, IS ), 1 ) REMAX = ONE / ABS( VR( II, IS ) ) CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) * DO 70 K = KI + 1, N VR( K, IS ) = ZERO 70 CONTINUE ELSE IF( KI.GT.1 ) $ CALL DGEMV( 'N', N, KI-1, ONE, VR, LDVR, $ WORK( 1+N ), 1, WORK( KI+N ), $ VR( 1, KI ), 1 ) * II = IDAMAX( N, VR( 1, KI ), 1 ) REMAX = ONE / ABS( VR( II, KI ) ) CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) END IF * ELSE * * Complex right eigenvector. * * Initial solve * [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. * [ (T(KI,KI-1) T(KI,KI) ) ] * IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN WORK( KI-1+N ) = ONE WORK( KI+N2 ) = WI / T( KI-1, KI ) ELSE WORK( KI-1+N ) = -WI / T( KI, KI-1 ) WORK( KI+N2 ) = ONE END IF WORK( KI+N ) = ZERO WORK( KI-1+N2 ) = ZERO * * Form right-hand side * DO 80 K = 1, KI - 2 WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 ) WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI ) 80 CONTINUE * * Solve upper quasi-triangular system: * (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) * JNXT = KI - 2 DO 90 J = KI - 2, 1, -1 IF( J.GT.JNXT ) $ GO TO 90 J1 = J J2 = J JNXT = J - 1 IF( J.GT.1 ) THEN IF( T( J, J-1 ).NE.ZERO ) THEN J1 = J - 1 JNXT = J - 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, WI, $ X, 2, SCALE, XNORM, IERR ) * * Scale X(1,1) and X(1,2) to avoid overflow when * updating the right-hand side. * IF( XNORM.GT.ONE ) THEN IF( WORK( J ).GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM X( 1, 2 ) = X( 1, 2 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) * * Update the right-hand side * CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1, $ WORK( 1+N2 ), 1 ) * ELSE * * 2-by-2 diagonal block * CALL DLALN2( .FALSE., 2, 2, SMIN, ONE, $ T( J-1, J-1 ), LDT, ONE, ONE, $ WORK( J-1+N ), N, WR, WI, X, 2, SCALE, $ XNORM, IERR ) * * Scale X to avoid overflow when updating * the right-hand side. * IF( XNORM.GT.ONE ) THEN BETA = MAX( WORK( J-1 ), WORK( J ) ) IF( BETA.GT.BIGNUM / XNORM ) THEN REC = ONE / XNORM X( 1, 1 ) = X( 1, 1 )*REC X( 1, 2 ) = X( 1, 2 )*REC X( 2, 1 ) = X( 2, 1 )*REC X( 2, 2 ) = X( 2, 2 )*REC SCALE = SCALE*REC END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) END IF WORK( J-1+N ) = X( 1, 1 ) WORK( J+N ) = X( 2, 1 ) WORK( J-1+N2 ) = X( 1, 2 ) WORK( J+N2 ) = X( 2, 2 ) * * Update the right-hand side * CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1, $ WORK( 1+N2 ), 1 ) CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, $ WORK( 1+N2 ), 1 ) END IF 90 CONTINUE * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 ) CALL DCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 ) * EMAX = ZERO DO 100 K = 1, KI EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+ $ ABS( VR( K, IS ) ) ) 100 CONTINUE * REMAX = ONE / EMAX CALL DSCAL( KI, REMAX, VR( 1, IS-1 ), 1 ) CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) * DO 110 K = KI + 1, N VR( K, IS-1 ) = ZERO VR( K, IS ) = ZERO 110 CONTINUE * ELSE * IF( KI.GT.2 ) THEN CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, $ WORK( 1+N ), 1, WORK( KI-1+N ), $ VR( 1, KI-1 ), 1 ) CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, $ WORK( 1+N2 ), 1, WORK( KI+N2 ), $ VR( 1, KI ), 1 ) ELSE CALL DSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 ) CALL DSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 ) END IF * EMAX = ZERO DO 120 K = 1, N EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+ $ ABS( VR( K, KI ) ) ) 120 CONTINUE REMAX = ONE / EMAX CALL DSCAL( N, REMAX, VR( 1, KI-1 ), 1 ) CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) END IF END IF * IS = IS - 1 IF( IP.NE.0 ) $ IS = IS - 1 130 CONTINUE IF( IP.EQ.1 ) $ IP = 0 IF( IP.EQ.-1 ) $ IP = 1 140 CONTINUE END IF * IF( LEFTV ) THEN * * Compute left eigenvectors. * IP = 0 IS = 1 DO 260 KI = 1, N * IF( IP.EQ.-1 ) $ GO TO 250 IF( KI.EQ.N ) $ GO TO 150 IF( T( KI+1, KI ).EQ.ZERO ) $ GO TO 150 IP = 1 * 150 CONTINUE IF( SOMEV ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 250 END IF * * Compute the KI-th eigenvalue (WR,WI). * WR = T( KI, KI ) WI = ZERO IF( IP.NE.0 ) $ WI = SQRT( ABS( T( KI, KI+1 ) ) )* $ SQRT( ABS( T( KI+1, KI ) ) ) SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) * IF( IP.EQ.0 ) THEN * * Real left eigenvector. * WORK( KI+N ) = ONE * * Form right-hand side * DO 160 K = KI + 1, N WORK( K+N ) = -T( KI, K ) 160 CONTINUE * * Solve the quasi-triangular system: * (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK * VMAX = ONE VCRIT = BIGNUM * JNXT = KI + 1 DO 170 J = KI + 1, N IF( J.LT.JNXT ) $ GO TO 170 J1 = J J2 = J JNXT = J + 1 IF( J.LT.N ) THEN IF( T( J+1, J ).NE.ZERO ) THEN J2 = J + 1 JNXT = J + 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side. * IF( WORK( J ).GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-1, T( KI+1, J ), 1, $ WORK( KI+1+N ), 1 ) * * Solve (T(J,J)-WR)'*X = WORK * CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) WORK( J+N ) = X( 1, 1 ) VMAX = MAX( ABS( WORK( J+N ) ), VMAX ) VCRIT = BIGNUM / VMAX * ELSE * * 2-by-2 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side. * BETA = MAX( WORK( J ), WORK( J+1 ) ) IF( BETA.GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-1, T( KI+1, J ), 1, $ WORK( KI+1+N ), 1 ) * WORK( J+1+N ) = WORK( J+1+N ) - $ DDOT( J-KI-1, T( KI+1, J+1 ), 1, $ WORK( KI+1+N ), 1 ) * * Solve * [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 ) * [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) WORK( J+N ) = X( 1, 1 ) WORK( J+1+N ) = X( 2, 1 ) * VMAX = MAX( ABS( WORK( J+N ) ), $ ABS( WORK( J+1+N ) ), VMAX ) VCRIT = BIGNUM / VMAX * END IF 170 CONTINUE * * Copy the vector x or Q*x to VL and normalize. * IF( .NOT.OVER ) THEN CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) * II = IDAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 REMAX = ONE / ABS( VL( II, IS ) ) CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) * DO 180 K = 1, KI - 1 VL( K, IS ) = ZERO 180 CONTINUE * ELSE * IF( KI.LT.N ) $ CALL DGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL, $ WORK( KI+1+N ), 1, WORK( KI+N ), $ VL( 1, KI ), 1 ) * II = IDAMAX( N, VL( 1, KI ), 1 ) REMAX = ONE / ABS( VL( II, KI ) ) CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) * END IF * ELSE * * Complex left eigenvector. * * Initial solve: * ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0. * ((T(KI+1,KI) T(KI+1,KI+1)) ) * IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN WORK( KI+N ) = WI / T( KI, KI+1 ) WORK( KI+1+N2 ) = ONE ELSE WORK( KI+N ) = ONE WORK( KI+1+N2 ) = -WI / T( KI+1, KI ) END IF WORK( KI+1+N ) = ZERO WORK( KI+N2 ) = ZERO * * Form right-hand side * DO 190 K = KI + 2, N WORK( K+N ) = -WORK( KI+N )*T( KI, K ) WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K ) 190 CONTINUE * * Solve complex quasi-triangular system: * ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 * VMAX = ONE VCRIT = BIGNUM * JNXT = KI + 2 DO 200 J = KI + 2, N IF( J.LT.JNXT ) $ GO TO 200 J1 = J J2 = J JNXT = J + 1 IF( J.LT.N ) THEN IF( T( J+1, J ).NE.ZERO ) THEN J2 = J + 1 JNXT = J + 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * * Scale if necessary to avoid overflow when * forming the right-hand side elements. * IF( WORK( J ).GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N ), 1 ) WORK( J+N2 ) = WORK( J+N2 ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N2 ), 1 ) * * Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 * CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ -WI, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) VMAX = MAX( ABS( WORK( J+N ) ), $ ABS( WORK( J+N2 ) ), VMAX ) VCRIT = BIGNUM / VMAX * ELSE * * 2-by-2 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side elements. * BETA = MAX( WORK( J ), WORK( J+1 ) ) IF( BETA.GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N ), 1 ) * WORK( J+N2 ) = WORK( J+N2 ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N2 ), 1 ) * WORK( J+1+N ) = WORK( J+1+N ) - $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, $ WORK( KI+2+N ), 1 ) * WORK( J+1+N2 ) = WORK( J+1+N2 ) - $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, $ WORK( KI+2+N2 ), 1 ) * * Solve 2-by-2 complex linear equation * ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B * ([T(j+1,j) T(j+1,j+1)] ) * CALL DLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ -WI, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) WORK( J+1+N ) = X( 2, 1 ) WORK( J+1+N2 ) = X( 2, 2 ) VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ), $ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX ) VCRIT = BIGNUM / VMAX * END IF 200 CONTINUE * * Copy the vector x or Q*x to VL and normalize. * 210 CONTINUE IF( .NOT.OVER ) THEN CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) CALL DCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ), $ 1 ) * EMAX = ZERO DO 220 K = KI, N EMAX = MAX( EMAX, ABS( VL( K, IS ) )+ $ ABS( VL( K, IS+1 ) ) ) 220 CONTINUE REMAX = ONE / EMAX CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) CALL DSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 ) * DO 230 K = 1, KI - 1 VL( K, IS ) = ZERO VL( K, IS+1 ) = ZERO 230 CONTINUE ELSE IF( KI.LT.N-1 ) THEN CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), $ LDVL, WORK( KI+2+N ), 1, WORK( KI+N ), $ VL( 1, KI ), 1 ) CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), $ LDVL, WORK( KI+2+N2 ), 1, $ WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) ELSE CALL DSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 ) CALL DSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) END IF * EMAX = ZERO DO 240 K = 1, N EMAX = MAX( EMAX, ABS( VL( K, KI ) )+ $ ABS( VL( K, KI+1 ) ) ) 240 CONTINUE REMAX = ONE / EMAX CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) CALL DSCAL( N, REMAX, VL( 1, KI+1 ), 1 ) * END IF * END IF * IS = IS + 1 IF( IP.NE.0 ) $ IS = IS + 1 250 CONTINUE IF( IP.EQ.-1 ) $ IP = 0 IF( IP.EQ.1 ) $ IP = -1 * 260 CONTINUE * END IF * RETURN * * End of DTREVC * END INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1998 * * .. Scalar Arguments .. INTEGER ISPEC REAL ONE, ZERO * .. * * Purpose * ======= * * IEEECK is called from the ILAENV to verify that Infinity and * possibly NaN arithmetic is safe (i.e. will not trap). * * Arguments * ========= * * ISPEC (input) INTEGER * Specifies whether to test just for inifinity arithmetic * or whether to test for infinity and NaN arithmetic. * = 0: Verify infinity arithmetic only. * = 1: Verify infinity and NaN arithmetic. * * ZERO (input) REAL * Must contain the value 0.0 * This is passed to prevent the compiler from optimizing * away this code. * * ONE (input) REAL * Must contain the value 1.0 * This is passed to prevent the compiler from optimizing * away this code. * * RETURN VALUE: INTEGER * = 0: Arithmetic failed to produce the correct answers * = 1: Arithmetic produced the correct answers * * .. Local Scalars .. REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, $ NEGZRO, NEWZRO, POSINF * .. * .. Executable Statements .. IEEECK = 1 * POSINF = ONE / ZERO IF( POSINF.LE.ONE ) THEN IEEECK = 0 RETURN END IF * NEGINF = -ONE / ZERO IF( NEGINF.GE.ZERO ) THEN IEEECK = 0 RETURN END IF * NEGZRO = ONE / ( NEGINF+ONE ) IF( NEGZRO.NE.ZERO ) THEN IEEECK = 0 RETURN END IF * NEGINF = ONE / NEGZRO IF( NEGINF.GE.ZERO ) THEN IEEECK = 0 RETURN END IF * NEWZRO = NEGZRO + ZERO IF( NEWZRO.NE.ZERO ) THEN IEEECK = 0 RETURN END IF * POSINF = ONE / NEWZRO IF( POSINF.LE.ONE ) THEN IEEECK = 0 RETURN END IF * NEGINF = NEGINF*POSINF IF( NEGINF.GE.ZERO ) THEN IEEECK = 0 RETURN END IF * POSINF = POSINF*POSINF IF( POSINF.LE.ONE ) THEN IEEECK = 0 RETURN END IF * * * * * Return if we were only asked to check infinity arithmetic * IF( ISPEC.EQ.0 ) $ RETURN * NAN1 = POSINF + NEGINF * NAN2 = POSINF / NEGINF * NAN3 = POSINF / POSINF * NAN4 = POSINF*ZERO * NAN5 = NEGINF*NEGZRO * NAN6 = NAN5*0.0 * IF( NAN1.EQ.NAN1 ) THEN IEEECK = 0 RETURN END IF * IF( NAN2.EQ.NAN2 ) THEN IEEECK = 0 RETURN END IF * IF( NAN3.EQ.NAN3 ) THEN IEEECK = 0 RETURN END IF * IF( NAN4.EQ.NAN4 ) THEN IEEECK = 0 RETURN END IF * IF( NAN5.EQ.NAN5 ) THEN IEEECK = 0 RETURN END IF * IF( NAN6.EQ.NAN6 ) THEN IEEECK = 0 RETURN END IF * RETURN END INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, $ N4 ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS INTEGER ISPEC, N1, N2, N3, N4 * .. * * Purpose * ======= * * ILAENV is called from the LAPACK routines to choose problem-dependent * parameters for the local environment. See ISPEC for a description of * the parameters. * * This version provides a set of parameters which should give good, * but not optimal, performance on many of the currently available * computers. Users are encouraged to modify this subroutine to set * the tuning parameters for their particular machine using the option * and problem size information in the arguments. * * This routine will not function correctly if it is converted to all * lower case. Converting it to all upper case is allowed. * * Arguments * ========= * * ISPEC (input) INTEGER * Specifies the parameter to be returned as the value of * ILAENV. * = 1: the optimal blocksize; if this value is 1, an unblocked * algorithm will give the best performance. * = 2: the minimum block size for which the block routine * should be used; if the usable block size is less than * this value, an unblocked routine should be used. * = 3: the crossover point (in a block routine, for N less * than this value, an unblocked routine should be used) * = 4: the number of shifts, used in the nonsymmetric * eigenvalue routines * = 5: the minimum column dimension for blocking to be used; * rectangular blocks must have dimension at least k by m, * where k is given by ILAENV(2,...) and m by ILAENV(5,...) * = 6: the crossover point for the SVD (when reducing an m by n * matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds * this value, a QR factorization is used first to reduce * the matrix to a triangular form.) * = 7: the number of processors * = 8: the crossover point for the multishift QR and QZ methods * for nonsymmetric eigenvalue problems. * = 9: maximum size of the subproblems at the bottom of the * computation tree in the divide-and-conquer algorithm * (used by xGELSD and xGESDD) * =10: ieee NaN arithmetic can be trusted not to trap * =11: infinity arithmetic can be trusted not to trap * * NAME (input) CHARACTER*(*) * The name of the calling subroutine, in either upper case or * lower case. * * OPTS (input) CHARACTER*(*) * The character options to the subroutine NAME, concatenated * into a single character string. For example, UPLO = 'U', * TRANS = 'T', and DIAG = 'N' for a triangular routine would * be specified as OPTS = 'UTN'. * * N1 (input) INTEGER * N2 (input) INTEGER * N3 (input) INTEGER * N4 (input) INTEGER * Problem dimensions for the subroutine NAME; these may not all * be required. * * (ILAENV) (output) INTEGER * >= 0: the value of the parameter specified by ISPEC * < 0: if ILAENV = -k, the k-th argument had an illegal value. * * Further Details * =============== * * The following conventions have been used when calling ILAENV from the * LAPACK routines: * 1) OPTS is a concatenation of all of the character options to * subroutine NAME, in the same order that they appear in the * argument list for NAME, even if they are not used in determining * the value of the parameter specified by ISPEC. * 2) The problem dimensions N1, N2, N3, N4 are specified in the order * that they appear in the argument list for NAME. N1 is used * first, N2 second, and so on, and unused problem dimensions are * passed a value of -1. * 3) The parameter value returned by ILAENV is checked for validity in * the calling subroutine. For example, ILAENV is used to retrieve * the optimal blocksize for STRTRI as follows: * * NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) * IF( NB.LE.1 ) NB = MAX( 1, N ) * * ===================================================================== * * .. Local Scalars .. LOGICAL CNAME, SNAME CHARACTER*1 C1 CHARACTER*2 C2, C4 CHARACTER*3 C3 CHARACTER*6 SUBNAM INTEGER I, IC, IZ, NB, NBMIN, NX * .. * .. Intrinsic Functions .. INTRINSIC CHAR, ICHAR, INT, MIN, REAL * .. * .. External Functions .. INTEGER IEEECK EXTERNAL IEEECK * .. * .. Executable Statements .. * GO TO ( 100, 100, 100, 400, 500, 600, 700, 800, 900, 1000, $ 1100 ) ISPEC * * Invalid value for ISPEC * ILAENV = -1 RETURN * 100 CONTINUE * * Convert NAME to upper case if the first character is lower case. * ILAENV = 1 SUBNAM = NAME IC = ICHAR( SUBNAM( 1:1 ) ) IZ = ICHAR( 'Z' ) IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN * * ASCII character set * IF( IC.GE.97 .AND. IC.LE.122 ) THEN SUBNAM( 1:1 ) = CHAR( IC-32 ) DO 10 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( IC.GE.97 .AND. IC.LE.122 ) $ SUBNAM( I:I ) = CHAR( IC-32 ) 10 CONTINUE END IF * ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN * * EBCDIC character set * IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN SUBNAM( 1:1 ) = CHAR( IC+64 ) DO 20 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) $ SUBNAM( I:I ) = CHAR( IC+64 ) 20 CONTINUE END IF * ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN * * Prime machines: ASCII+128 * IF( IC.GE.225 .AND. IC.LE.250 ) THEN SUBNAM( 1:1 ) = CHAR( IC-32 ) DO 30 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( IC.GE.225 .AND. IC.LE.250 ) $ SUBNAM( I:I ) = CHAR( IC-32 ) 30 CONTINUE END IF END IF * C1 = SUBNAM( 1:1 ) SNAME = C1.EQ.'S' .OR. C1.EQ.'D' CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' IF( .NOT.( CNAME .OR. SNAME ) ) $ RETURN C2 = SUBNAM( 2:3 ) C3 = SUBNAM( 4:6 ) C4 = C3( 2:3 ) * GO TO ( 110, 200, 300 ) ISPEC * 110 CONTINUE * * ISPEC = 1: block size * * In these examples, separate code is provided for setting NB for * real and complex. We assume that NB will take the same value in * single or double precision. * NB = 1 * IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'PO' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NB = 32 ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRF' ) THEN NB = 64 ELSE IF( C3.EQ.'TRD' ) THEN NB = 32 ELSE IF( C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF END IF ELSE IF( C2.EQ.'GB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'PB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'TR' ) THEN IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'LA' ) THEN IF( C3.EQ.'UUM' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN IF( C3.EQ.'EBZ' ) THEN NB = 1 END IF END IF ILAENV = NB RETURN * 200 CONTINUE * * ISPEC = 2: minimum block size * NBMIN = 2 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NBMIN = 8 ELSE NBMIN = 8 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF END IF END IF ILAENV = NBMIN RETURN * 300 CONTINUE * * ISPEC = 3: crossover point * NX = 0 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( SNAME .AND. C3.EQ.'TRD' ) THEN NX = 32 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NX = 32 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NX = 128 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NX = 128 END IF END IF END IF ILAENV = NX RETURN * 400 CONTINUE * * ISPEC = 4: number of shifts (used by xHSEQR) * ILAENV = 6 RETURN * 500 CONTINUE * * ISPEC = 5: minimum column dimension (not used) * ILAENV = 2 RETURN * 600 CONTINUE * * ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) * ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) RETURN * 700 CONTINUE * * ISPEC = 7: number of processors (not used) * ILAENV = 1 RETURN * 800 CONTINUE * * ISPEC = 8: crossover point for multishift (used by xHSEQR) * ILAENV = 50 RETURN * 900 CONTINUE * * ISPEC = 9: maximum size of the subproblems at the bottom of the * computation tree in the divide-and-conquer algorithm * (used by xGELSD and xGESDD) * ILAENV = 25 RETURN * 1000 CONTINUE * * ISPEC = 10: ieee NaN arithmetic can be trusted not to trap * C ILAENV = 0 ILAENV = 1 IF( ILAENV.EQ.1 ) THEN ILAENV = IEEECK( 0, 0.0, 1.0 ) END IF RETURN * 1100 CONTINUE * * ISPEC = 11: infinity arithmetic can be trusted not to trap * C ILAENV = 0 ILAENV = 1 IF( ILAENV.EQ.1 ) THEN ILAENV = IEEECK( 1, 0.0, 1.0 ) END IF RETURN * * End of ILAENV * END