diff options
44 files changed, 157 insertions, 137 deletions
diff --git a/INSTALL/lsametst.f b/INSTALL/lsametst.f index d51169b9..236719e7 100644 --- a/INSTALL/lsametst.f +++ b/INSTALL/lsametst.f @@ -4,6 +4,7 @@ * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * +* ===================================================================== * .. Local Scalars .. INTEGER I1, I2 * .. diff --git a/SRC/VARIANTS/lu/CR/cgetrf.f b/SRC/VARIANTS/lu/CR/cgetrf.f index 7d6403e1..8e6270b3 100644 --- a/SRC/VARIANTS/lu/CR/cgetrf.f +++ b/SRC/VARIANTS/lu/CR/cgetrf.f @@ -72,7 +72,7 @@ EXTERNAL ILAENV * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN, MOD + INTRINSIC MAX, MIN * .. * .. Executable Statements .. * diff --git a/SRC/VARIANTS/lu/CR/dgetrf.f b/SRC/VARIANTS/lu/CR/dgetrf.f index e1b4121e..359e00e7 100644 --- a/SRC/VARIANTS/lu/CR/dgetrf.f +++ b/SRC/VARIANTS/lu/CR/dgetrf.f @@ -72,7 +72,7 @@ EXTERNAL ILAENV * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN, MOD + INTRINSIC MAX, MIN * .. * .. Executable Statements .. * diff --git a/SRC/VARIANTS/lu/CR/sgetrf.f b/SRC/VARIANTS/lu/CR/sgetrf.f index 238ec119..c8b89009 100644 --- a/SRC/VARIANTS/lu/CR/sgetrf.f +++ b/SRC/VARIANTS/lu/CR/sgetrf.f @@ -72,7 +72,7 @@ EXTERNAL ILAENV * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN, MOD + INTRINSIC MAX, MIN * .. * .. Executable Statements .. * diff --git a/SRC/VARIANTS/lu/CR/zgetrf.f b/SRC/VARIANTS/lu/CR/zgetrf.f index 2dafefbf..fede7e22 100644 --- a/SRC/VARIANTS/lu/CR/zgetrf.f +++ b/SRC/VARIANTS/lu/CR/zgetrf.f @@ -72,7 +72,7 @@ EXTERNAL ILAENV * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN, MOD + INTRINSIC MAX, MIN * .. * .. Executable Statements .. * diff --git a/SRC/cpoequb.f b/SRC/cpoequb.f index 70686e01..93e0a5a2 100644 --- a/SRC/cpoequb.f +++ b/SRC/cpoequb.f @@ -81,7 +81,7 @@ EXTERNAL XERBLA * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT, LOG, INT, REAL, AIMAG + INTRINSIC MAX, MIN, SQRT, LOG, INT * .. * .. Executable Statements .. * diff --git a/SRC/csysv.f b/SRC/csysv.f index fd754ad1..17e22a3e 100644 --- a/SRC/csysv.f +++ b/SRC/csysv.f @@ -112,8 +112,7 @@ * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, CSYTRF, CSYTRS, CSYTRS2 diff --git a/SRC/dorbdb.f b/SRC/dorbdb.f index 1c3fcbcc..6123ba35 100644 --- a/SRC/dorbdb.f +++ b/SRC/dorbdb.f @@ -208,7 +208,7 @@ EXTERNAL DNRM2, LSAME * .. * .. Intrinsic Functions - INTRINSIC ATAN2, COS, MAX, MIN, SIN + INTRINSIC ATAN2, COS, MAX, SIN * .. * .. Executable Statements .. * diff --git a/SRC/dorcsd.f b/SRC/dorcsd.f index a4a0b18e..ca5596d3 100644 --- a/SRC/dorcsd.f +++ b/SRC/dorcsd.f @@ -192,7 +192,7 @@ EXTERNAL LSAME * .. * .. Intrinsic Functions - INTRINSIC COS, INT, MAX, MIN, SIN + INTRINSIC INT, MAX, MIN * .. * .. Executable Statements .. * diff --git a/SRC/dsysv.f b/SRC/dsysv.f index f719b406..ce166738 100644 --- a/SRC/dsysv.f +++ b/SRC/dsysv.f @@ -112,8 +112,7 @@ * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, DSYTRF, DSYTRS, DSYTRS2 diff --git a/SRC/ilaclr.f b/SRC/ilaclr.f index 2d71bd47..9d8a8c72 100644 --- a/SRC/ilaclr.f +++ b/SRC/ilaclr.f @@ -54,12 +54,12 @@ ILACLR = 0 DO J = 1, N I=M - DO WHILE ((A(I,J).EQ.ZERO).AND.(I.GT.1)) - I=I-1 - ENDDO - IF( (I.EQ.1).AND.(A(1,J).EQ.ZERO) ) THEN - I = 0 - END IF + DO WHILE ((A(I,J).NE.ZERO).AND.(I.GE.1)) + I=I-1 + IF (I.EQ.0) THEN + EXIT + END IF + ENDDO ILACLR = MAX( ILACLR, I ) END DO END IF diff --git a/SRC/iladlr.f b/SRC/iladlr.f index e9f86a03..f42bcf17 100644 --- a/SRC/iladlr.f +++ b/SRC/iladlr.f @@ -53,13 +53,13 @@ * Scan up each column tracking the last zero row seen. ILADLR = 0 DO J = 1, N - I = M - DO WHILE ((A(I,J).EQ.ZERO).AND.(I.GT.1)) - I=I-1 + I=M + DO WHILE ((A(I,J).NE.ZERO).AND.(I.GE.1)) + I=I-1 + IF (I.EQ.0) THEN + EXIT + END IF ENDDO - IF( (I.EQ.1).AND.(A(1,J).EQ.ZERO) ) THEN - I = 0 - END IF ILADLR = MAX( ILADLR, I ) END DO END IF diff --git a/SRC/ilaslr.f b/SRC/ilaslr.f index 12511b36..9579efa1 100644 --- a/SRC/ilaslr.f +++ b/SRC/ilaslr.f @@ -54,12 +54,12 @@ ILASLR = 0 DO J = 1, N I=M - DO WHILE ((A(I,J).EQ.ZERO).AND.(I.GT.1)) - I=I-1 + DO WHILE ((A(I,J).NE.ZERO).AND.(I.GE.1)) + I=I-1 + IF (I.EQ.0) THEN + EXIT + END IF ENDDO - IF( (I.EQ.1).AND.(A(1,J).EQ.ZERO) ) THEN - I = 0 - END IF ILASLR = MAX( ILASLR, I ) END DO END IF diff --git a/SRC/ilazlr.f b/SRC/ilazlr.f index 44902e4b..0634b04a 100644 --- a/SRC/ilazlr.f +++ b/SRC/ilazlr.f @@ -53,12 +53,12 @@ ILAZLR = 0 DO J = 1, N I=M - DO WHILE ((A(I,J).EQ.ZERO).AND.(I.GT.1)) - I=I-1 - ENDDO - IF( (I.EQ.1).AND.(A(1,J).EQ.ZERO) ) THEN - I = 0 - END IF + DO WHILE ((A(I,J).NE.ZERO).AND.(I.GE.1)) + I=I-1 + IF (I.EQ.0) THEN + EXIT + END IF + ENDDO ILAZLR = MAX( ILAZLR, I ) END DO END IF diff --git a/SRC/sgsvj0.f b/SRC/sgsvj0.f index eeaaab7e..58f389b2 100644 --- a/SRC/sgsvj0.f +++ b/SRC/sgsvj0.f @@ -161,7 +161,7 @@ REAL FASTR( 5 ) * .. * .. Intrinsic Functions .. - INTRINSIC ABS, AMAX1, AMIN1, FLOAT, MIN0, SIGN, SQRT + INTRINSIC ABS, AMAX1, FLOAT, MIN0, SIGN, SQRT * .. * .. External Functions .. REAL SDOT, SNRM2 diff --git a/SRC/sorbdb.f b/SRC/sorbdb.f index 0c9cedd5..2ea05c38 100644 --- a/SRC/sorbdb.f +++ b/SRC/sorbdb.f @@ -208,7 +208,7 @@ EXTERNAL SNRM2, LSAME * .. * .. Intrinsic Functions - INTRINSIC ATAN2, COS, MAX, MIN, SIN + INTRINSIC ATAN2, COS, MAX, SIN * .. * .. Executable Statements .. * diff --git a/SRC/sorcsd.f b/SRC/sorcsd.f index e8dc9681..306889eb 100644 --- a/SRC/sorcsd.f +++ b/SRC/sorcsd.f @@ -170,6 +170,9 @@ $ PIOVER2 = 1.57079632679489662E0, $ ZERO = 0.0E+0 ) * .. +* .. Local Arrays .. + REAL DUMMY(1) +* .. * .. Local Scalars .. CHARACTER TRANST, SIGNST INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E, @@ -192,7 +195,7 @@ EXTERNAL LSAME * .. * .. Intrinsic Functions - INTRINSIC COS, INT, MAX, MIN, SIN + INTRINSIC INT, MAX, MIN * .. * .. Executable Statements .. * @@ -271,19 +274,19 @@ ITAUQ1 = ITAUP2 + MAX( 1, M - P ) ITAUQ2 = ITAUQ1 + MAX( 1, Q ) IORGQR = ITAUQ2 + MAX( 1, M - Q ) - CALL SORGQR( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1, + CALL SORGQR( M-Q, M-Q, M-Q, DUMMY, MAX(1,M-Q), DUMMY, WORK, -1, $ CHILDINFO ) LORGQRWORKOPT = INT( WORK(1) ) LORGQRWORKMIN = MAX( 1, M - Q ) IORGLQ = ITAUQ2 + MAX( 1, M - Q ) - CALL SORGLQ( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1, + CALL SORGLQ( M-Q, M-Q, M-Q, DUMMY, MAX(1,M-Q), DUMMY, WORK, -1, $ CHILDINFO ) LORGLQWORKOPT = INT( WORK(1) ) LORGLQWORKMIN = MAX( 1, M - Q ) IORBDB = ITAUQ2 + MAX( 1, M - Q ) CALL SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, - $ X21, LDX21, X22, LDX22, 0, 0, 0, 0, 0, 0, WORK, - $ -1, CHILDINFO ) + $ X21, LDX21, X22, LDX22, DUMMY, DUMMY, DUMMY, DUMMY, DUMMY, + $ DUMMY,WORK,-1,CHILDINFO ) LORBDBWORKOPT = INT( WORK(1) ) LORBDBWORKMIN = LORBDBWORKOPT IB11D = ITAUQ2 + MAX( 1, M - Q ) @@ -295,9 +298,10 @@ IB22D = IB21E + MAX( 1, Q - 1 ) IB22E = IB22D + MAX( 1, Q ) IBBCSD = IB22E + MAX( 1, Q - 1 ) - CALL SBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, 0, - $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, 0, - $ 0, 0, 0, 0, 0, 0, 0, WORK, -1, CHILDINFO ) + CALL SBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, + $ DUMMY, DUMMY, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, + $ LDV2T, DUMMY, DUMMY, DUMMY, DUMMY, DUMMY, DUMMY, + $ DUMMY, DUMMY, WORK, -1, CHILDINFO ) LBBCSDWORKOPT = INT( WORK(1) ) LBBCSDWORKMIN = LBBCSDWORKOPT LWORKOPT = MAX( IORGQR + LORGQRWORKOPT, IORGLQ + LORGLQWORKOPT, diff --git a/SRC/ssysv.f b/SRC/ssysv.f index b4b35051..4f73e7ab 100644 --- a/SRC/ssysv.f +++ b/SRC/ssysv.f @@ -112,8 +112,7 @@ * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, SSYTRF, SSYTRS, SSYTRS2 @@ -145,7 +144,7 @@ IF( N.EQ.0 ) THEN LWKOPT = 1 ELSE - CALL SSYTRF( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) + CALL SSYTRF( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) LWKOPT = WORK(1) END IF WORK( 1 ) = LWKOPT diff --git a/SRC/zgeequb.f b/SRC/zgeequb.f index a2931c6a..32fe3e5a 100644 --- a/SRC/zgeequb.f +++ b/SRC/zgeequb.f @@ -106,7 +106,7 @@ EXTERNAL XERBLA * .. * .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, LOG, REAL, DIMAG + INTRINSIC ABS, MAX, MIN, LOG, DBLE, DIMAG * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 diff --git a/SRC/zsysv.f b/SRC/zsysv.f index e027fe40..dd4a0dae 100644 --- a/SRC/zsysv.f +++ b/SRC/zsysv.f @@ -112,8 +112,7 @@ * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZSYTRF, ZSYTRS, ZSYTRS2 diff --git a/TESTING/EIG/cchkee.f b/TESTING/EIG/cchkee.f index aef0b0be..7370a65d 100644 --- a/TESTING/EIG/cchkee.f +++ b/TESTING/EIG/cchkee.f @@ -1204,6 +1204,7 @@ * READ( NIN, FMT = * )THRESH CALL XLAENV( 1, 1 ) + CALL XLAENV( 12, 1 ) TSTERR = .TRUE. CALL CCHKEC( THRESH, TSTERR, NIN, NOUT ) GO TO 380 @@ -2314,7 +2315,7 @@ $ CALL CERRGG( 'CSD', NOUT ) CALL CCKCSD( NN, MVAL, PVAL, NVAL, NTYPES, ISEED, THRESH, NMAX, $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), - $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), IWORK, WORK, + $ A( 1, 5 ), A( 1, 6 ), RWORK, IWORK, WORK, $ DR( 1, 1 ), NIN, NOUT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'CCKCSD', INFO diff --git a/TESTING/EIG/cckcsd.f b/TESTING/EIG/cckcsd.f index e081652e..f454e3c0 100644 --- a/TESTING/EIG/cckcsd.f +++ b/TESTING/EIG/cckcsd.f @@ -128,11 +128,11 @@ $ CLASET * .. * .. Intrinsic Functions .. - INTRINSIC ABS, COS, MIN, SIN + INTRINSIC ABS, MIN * .. * .. External Functions .. - REAL CLANGE, SLARND - EXTERNAL CLANGE, SLARND + REAL SLARND + EXTERNAL SLARND * .. * .. Executable Statements .. * diff --git a/TESTING/EIG/ccsdts.f b/TESTING/EIG/ccsdts.f index 6054f5aa..e4362fa8 100644 --- a/TESTING/EIG/ccsdts.f +++ b/TESTING/EIG/ccsdts.f @@ -150,10 +150,14 @@ ULP = SLAMCH( 'Precision' ) ULPINV = REALONE / ULP CALL CLASET( 'Full', M, M, ZERO, ONE, WORK, LDX ) - CALL CHERK( 'Upper', 'Conjugate transpose', M, M, -ONE, X, LDX, - $ ONE, WORK, LDX ) - EPS2 = MAX( ULP, - $ CLANGE( '1', M, M, WORK, LDX, RWORK ) / REAL( M ) ) + CALL CHERK( 'Upper', 'Conjugate transpose', M, M, -REALONE, + $ X, LDX, REALONE, WORK, LDX ) + IF (M.GT.0) THEN + EPS2 = MAX( ULP, + $ CLANGE( '1', M, M, WORK, LDX, RWORK ) / REAL( M ) ) + ELSE + EPS2 = ULP + END IF R = MIN( P, M-P, Q, M-Q ) * * Copy the matrix X to the array XF. @@ -252,8 +256,8 @@ * Compute I - U1'*U1 * CALL CLASET( 'Full', P, P, ZERO, ONE, WORK, LDU1 ) - CALL CHERK( 'Upper', 'Conjugate transpose', P, P, -ONE, U1, LDU1, - $ ONE, WORK, LDU1 ) + CALL CHERK( 'Upper', 'Conjugate transpose', P, P, -REALONE, + $ U1, LDU1, REALONE, WORK, LDU1 ) * * Compute norm( I - U'*U ) / ( MAX(1,P) * ULP ) . * @@ -263,8 +267,8 @@ * Compute I - U2'*U2 * CALL CLASET( 'Full', M-P, M-P, ZERO, ONE, WORK, LDU2 ) - CALL CHERK( 'Upper', 'Conjugate transpose', M-P, M-P, -ONE, U2, - $ LDU2, ONE, WORK, LDU2 ) + CALL CHERK( 'Upper', 'Conjugate transpose', M-P, M-P, -REALONE, + $ U2, LDU2, REALONE, WORK, LDU2 ) * * Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) . * @@ -274,8 +278,8 @@ * Compute I - V1T*V1T' * CALL CLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDV1T ) - CALL CHERK( 'Upper', 'No transpose', Q, Q, -ONE, V1T, LDV1T, ONE, - $ WORK, LDV1T ) + CALL CHERK( 'Upper', 'No transpose', Q, Q, -REALONE, + $ V1T, LDV1T, REALONE, WORK, LDV1T ) * * Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) . * @@ -285,8 +289,8 @@ * Compute I - V2T*V2T' * CALL CLASET( 'Full', M-Q, M-Q, ZERO, ONE, WORK, LDV2T ) - CALL CHERK( 'Upper', 'No transpose', M-Q, M-Q, -ONE, V2T, LDV2T, - $ ONE, WORK, LDV2T ) + CALL CHERK( 'Upper', 'No transpose', M-Q, M-Q, -REALONE, + $ V2T, LDV2T, REALONE, WORK, LDV2T ) * * Compute norm( I - V2T*V2T' ) / ( MAX(1,M-Q) * ULP ) . * diff --git a/TESTING/EIG/cerrgg.f b/TESTING/EIG/cerrgg.f index 3a2532e6..5da0ccbf 100644 --- a/TESTING/EIG/cerrgg.f +++ b/TESTING/EIG/cerrgg.f @@ -35,8 +35,8 @@ * .. * .. Local Scalars .. CHARACTER*2 C2 - INTEGER DUMMYK, DUMMYL, I, IFST, ILST, INFO, J, M, - $ NCYCLE, NT, SDIM + INTEGER DUMMYK, DUMMYL, I, IFST, IHI, ILO, ILST, INFO, + $ J, M, NCYCLE, NT, SDIM REAL ANRM, BNRM, DIF, SCALE, TOLA, TOLB * .. * .. Local Arrays .. diff --git a/TESTING/EIG/dckcsd.f b/TESTING/EIG/dckcsd.f index 9981b4a9..9fdd5539 100644 --- a/TESTING/EIG/dckcsd.f +++ b/TESTING/EIG/dckcsd.f @@ -128,11 +128,11 @@ $ DLASET * .. * .. Intrinsic Functions .. - INTRINSIC ABS, COS, MIN, SIN + INTRINSIC ABS, MIN * .. * .. External Functions .. - DOUBLE PRECISION DLANGE, DLARND - EXTERNAL DLANGE, DLARND + DOUBLE PRECISION DLARND + EXTERNAL DLARND * .. * .. Executable Statements .. * diff --git a/TESTING/EIG/dcsdts.f b/TESTING/EIG/dcsdts.f index 83e5ab99..3b6762f0 100644 --- a/TESTING/EIG/dcsdts.f +++ b/TESTING/EIG/dcsdts.f @@ -152,8 +152,12 @@ CALL DLASET( 'Full', M, M, ZERO, ONE, WORK, LDX ) CALL DSYRK( 'Upper', 'Conjugate transpose', M, M, -ONE, X, LDX, $ ONE, WORK, LDX ) - EPS2 = MAX( ULP, - $ DLANGE( '1', M, M, WORK, LDX, RWORK ) / DBLE( M ) ) + IF (M.GT.0) THEN + EPS2 = MAX( ULP, + $ DLANGE( '1', M, M, WORK, LDX, RWORK ) / DBLE( M ) ) + ELSE + EPS2 = ULP + END IF R = MIN( P, M-P, Q, M-Q ) * * Copy the matrix X to the array XF. diff --git a/TESTING/EIG/sckcsd.f b/TESTING/EIG/sckcsd.f index 9c768be1..d6f4c22c 100644 --- a/TESTING/EIG/sckcsd.f +++ b/TESTING/EIG/sckcsd.f @@ -128,11 +128,11 @@ $ SLASET * .. * .. Intrinsic Functions .. - INTRINSIC ABS, COS, MIN, SIN + INTRINSIC ABS, MIN * .. * .. External Functions .. - REAL SLANGE, SLARND - EXTERNAL SLANGE, SLARND + REAL SLARND + EXTERNAL SLARND * .. * .. Executable Statements .. * diff --git a/TESTING/EIG/scsdts.f b/TESTING/EIG/scsdts.f index 214a0d6e..390c4354 100644 --- a/TESTING/EIG/scsdts.f +++ b/TESTING/EIG/scsdts.f @@ -152,8 +152,12 @@ CALL SLASET( 'Full', M, M, ZERO, ONE, WORK, LDX ) CALL SSYRK( 'Upper', 'Conjugate transpose', M, M, -ONE, X, LDX, $ ONE, WORK, LDX ) - EPS2 = MAX( ULP, - $ SLANGE( '1', M, M, WORK, LDX, RWORK ) / REAL( M ) ) + IF (M.GT.0) THEN + EPS2 = MAX( ULP, + $ SLANGE( '1', M, M, WORK, LDX, RWORK ) / REAL( M ) ) + ELSE + EPS2 = ULP + END IF R = MIN( P, M-P, Q, M-Q ) * * Copy the matrix X to the array XF. diff --git a/TESTING/EIG/zchkee.f b/TESTING/EIG/zchkee.f index dd3547e6..51f6a79b 100644 --- a/TESTING/EIG/zchkee.f +++ b/TESTING/EIG/zchkee.f @@ -1204,6 +1204,7 @@ * READ( NIN, FMT = * )THRESH CALL XLAENV( 1, 1 ) + CALL XLAENV( 12, 1 ) TSTERR = .TRUE. CALL ZCHKEC( THRESH, TSTERR, NIN, NOUT ) GO TO 380 @@ -2314,7 +2315,7 @@ $ CALL ZERRGG( 'CSD', NOUT ) CALL ZCKCSD( NN, MVAL, PVAL, NVAL, NTYPES, ISEED, THRESH, NMAX, $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), - $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), IWORK, WORK, + $ A( 1, 5 ), A( 1, 6 ), RWORK, IWORK, WORK, $ DR( 1, 1 ), NIN, NOUT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'ZCKCSD', INFO diff --git a/TESTING/EIG/zckcsd.f b/TESTING/EIG/zckcsd.f index 8f43067b..83b63045 100644 --- a/TESTING/EIG/zckcsd.f +++ b/TESTING/EIG/zckcsd.f @@ -128,11 +128,11 @@ $ ZLASET * .. * .. Intrinsic Functions .. - INTRINSIC ABS, COS, MIN, SIN + INTRINSIC ABS, MIN * .. * .. External Functions .. - DOUBLE PRECISION ZLANGE, DLARND - EXTERNAL ZLANGE, DLARND + DOUBLE PRECISION DLARND + EXTERNAL DLARND * .. * .. Executable Statements .. * diff --git a/TESTING/EIG/zcsdts.f b/TESTING/EIG/zcsdts.f index 3436d9ef..2aa7c448 100644 --- a/TESTING/EIG/zcsdts.f +++ b/TESTING/EIG/zcsdts.f @@ -150,10 +150,14 @@ ULP = DLAMCH( 'Precision' ) ULPINV = REALONE / ULP CALL ZLASET( 'Full', M, M, ZERO, ONE, WORK, LDX ) - CALL ZHERK( 'Upper', 'Conjugate transpose', M, M, -ONE, X, LDX, - $ ONE, WORK, LDX ) - EPS2 = MAX( ULP, - $ ZLANGE( '1', M, M, WORK, LDX, RWORK ) / REAL( M ) ) + CALL ZHERK( 'Upper', 'Conjugate transpose', M, M, -REALONE, + $ X, LDX, REALONE, WORK, LDX ) + IF (M.GT.0) THEN + EPS2 = MAX( ULP, + $ ZLANGE( '1', M, M, WORK, LDX, RWORK ) / DBLE( M ) ) + ELSE + EPS2 = ULP + END IF R = MIN( P, M-P, Q, M-Q ) * * Copy the matrix X to the array XF. @@ -252,8 +256,8 @@ * Compute I - U1'*U1 * CALL ZLASET( 'Full', P, P, ZERO, ONE, WORK, LDU1 ) - CALL ZHERK( 'Upper', 'Conjugate transpose', P, P, -ONE, U1, LDU1, - $ ONE, WORK, LDU1 ) + CALL ZHERK( 'Upper', 'Conjugate transpose', P, P, -REALONE, + $ U1, LDU1, REALONE, WORK, LDU1 ) * * Compute norm( I - U'*U ) / ( MAX(1,P) * ULP ) . * @@ -263,8 +267,8 @@ * Compute I - U2'*U2 * CALL ZLASET( 'Full', M-P, M-P, ZERO, ONE, WORK, LDU2 ) - CALL ZHERK( 'Upper', 'Conjugate transpose', M-P, M-P, -ONE, U2, - $ LDU2, ONE, WORK, LDU2 ) + CALL ZHERK( 'Upper', 'Conjugate transpose', M-P, M-P, -REALONE, + $ U2, LDU2, REALONE, WORK, LDU2 ) * * Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) . * @@ -274,8 +278,8 @@ * Compute I - V1T*V1T' * CALL ZLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDV1T ) - CALL ZHERK( 'Upper', 'No transpose', Q, Q, -ONE, V1T, LDV1T, ONE, - $ WORK, LDV1T ) + CALL ZHERK( 'Upper', 'No transpose', Q, Q, -REALONE, + $ V1T, LDV1T, REALONE, WORK, LDV1T ) * * Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) . * @@ -285,8 +289,8 @@ * Compute I - V2T*V2T' * CALL ZLASET( 'Full', M-Q, M-Q, ZERO, ONE, WORK, LDV2T ) - CALL ZHERK( 'Upper', 'No transpose', M-Q, M-Q, -ONE, V2T, LDV2T, - $ ONE, WORK, LDV2T ) + CALL ZHERK( 'Upper', 'No transpose', M-Q, M-Q, -REALONE, + $ V2T, LDV2T, REALONE, WORK, LDV2T ) * * Compute norm( I - V2T*V2T' ) / ( MAX(1,M-Q) * ULP ) . * diff --git a/TESTING/LIN/cdrvgbx.f b/TESTING/LIN/cdrvgbx.f index 3ba557cc..7bcb609a 100644 --- a/TESTING/LIN/cdrvgbx.f +++ b/TESTING/LIN/cdrvgbx.f @@ -723,9 +723,12 @@ c write(*,*) 'begin cgbsvxx testing' CALL CLACPY( 'Full', N, NRHS, BSAV, LDB, B, LDB ) IF( .NOT.PREFAC ) - $ CALL CLASET( 'Full', 2*KL+KU+1, N, ZERO, ZERO, - $ AFB, LDAFB ) - CALL CLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDB ) + $ CALL CLASET( 'Full', 2*KL+KU+1, N, + $ CMPLX( ZERO ), CMPLX( ZERO ), + $ AFB, LDAFB ) + CALL CLASET( 'Full', N, NRHS, + $ CMPLX( ZERO ), CMPLX( ZERO ), + $ X, LDB ) IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN * * Equilibrate the matrix if FACT = 'F' and @@ -778,7 +781,7 @@ c write(*,*) 'begin cgbsvxx testing' * residual. * CALL CGBT01( N, N, KL, KU, A, LDA, AFB, LDAFB, - $ IWORK, RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + $ IWORK, WORK( 2*NRHS+1 ), RESULT( 1 ) ) K1 = 1 ELSE K1 = 2 @@ -792,8 +795,7 @@ c write(*,*) 'begin cgbsvxx testing' CALL CLACPY( 'Full', N, NRHS, BSAV, LDB, WORK, $ LDB ) CALL CGBT02( TRANS, N, N, KL, KU, NRHS, ASAV, - $ LDA, X, LDB, WORK, LDB, RWORK( 2*NRHS+1 ), - $ RESULT( 2 ) ) + $ LDA, X, LDB, WORK, LDB, RESULT( 2 ) ) * * Check solution from generated exact solution. * diff --git a/TESTING/LIN/ddrvgbx.f b/TESTING/LIN/ddrvgbx.f index dc0be900..4be73fe5 100644 --- a/TESTING/LIN/ddrvgbx.f +++ b/TESTING/LIN/ddrvgbx.f @@ -791,7 +791,7 @@ $ LDB ) CALL DGBT02( TRANS, N, N, KL, KU, NRHS, ASAV, $ LDA, X, LDB, WORK, LDB, - $ WORK, RESULT( 2 ) ) + $ RESULT( 2 ) ) * * Check solution from generated exact solution. * diff --git a/TESTING/LIN/derrsy.f b/TESTING/LIN/derrsy.f index 36186814..8083b9ee 100644 --- a/TESTING/LIN/derrsy.f +++ b/TESTING/LIN/derrsy.f @@ -134,13 +134,13 @@ * SRNAMT = 'DSYTRI2' INFOT = 1 - CALL DSYTRI2( '/', 0, A, 1, IP, W, IW, INFO ) + CALL DSYTRI2( '/', 0, A, 1, IP, W, IW(1), INFO ) CALL CHKXER( 'DSYTRI2', INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL DSYTRI2( 'U', -1, A, 1, IP, W, IW, INFO ) + CALL DSYTRI2( 'U', -1, A, 1, IP, W, IW(1), INFO ) CALL CHKXER( 'DSYTRI2', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL DSYTRI2( 'U', 2, A, 1, IP, W, IW, INFO ) + CALL DSYTRI2( 'U', 2, A, 1, IP, W, IW(1), INFO ) CALL CHKXER( 'DSYTRI2', INFOT, NOUT, LERR, OK ) * * DSYTRS diff --git a/TESTING/LIN/dpot06.f b/TESTING/LIN/dpot06.f index d1c2df51..b5ca5cad 100644 --- a/TESTING/LIN/dpot06.f +++ b/TESTING/LIN/dpot06.f @@ -80,10 +80,9 @@ DOUBLE PRECISION ANORM, BNORM, EPS, XNORM * .. * .. External Functions .. - LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL LSAME, IDAMAX, DLAMCH, DLANSY + EXTERNAL IDAMAX, DLAMCH, DLANSY * .. * .. External Subroutines .. EXTERNAL DSYMM diff --git a/TESTING/LIN/serrsy.f b/TESTING/LIN/serrsy.f index 0f64e6de..7e218ef2 100644 --- a/TESTING/LIN/serrsy.f +++ b/TESTING/LIN/serrsy.f @@ -134,13 +134,13 @@ * SRNAMT = 'SSYTRI2' INFOT = 1 - CALL SSYTRI2( '/', 0, A, 1, IP, W, IW, INFO ) + CALL SSYTRI2( '/', 0, A, 1, IP, W, IW(1), INFO ) CALL CHKXER( 'SSYTRI2', INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL SSYTRI2( 'U', -1, A, 1, IP, W, IW, INFO ) + CALL SSYTRI2( 'U', -1, A, 1, IP, W, IW(1), INFO ) CALL CHKXER( 'SSYTRI2', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL SSYTRI2( 'U', 2, A, 1, IP, W, IW, INFO ) + CALL SSYTRI2( 'U', 2, A, 1, IP, W, IW(1), INFO ) CALL CHKXER( 'SSYTRI2', INFOT, NOUT, LERR, OK ) * * SSYTRS diff --git a/TESTING/LIN/zdrvac.f b/TESTING/LIN/zdrvac.f index e637598f..04bdcf79 100644 --- a/TESTING/LIN/zdrvac.f +++ b/TESTING/LIN/zdrvac.f @@ -100,10 +100,6 @@ * .. Local Variables .. INTEGER ITER, KASE * .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. * .. External Subroutines .. EXTERNAL ALAERH, ZLACPY, ZLAIPD, $ ZLARHS, ZLATB4, ZLATMS, diff --git a/TESTING/LIN/zdrvgbx.f b/TESTING/LIN/zdrvgbx.f index 416dd75c..2ef7b8a5 100644 --- a/TESTING/LIN/zdrvgbx.f +++ b/TESTING/LIN/zdrvgbx.f @@ -723,9 +723,12 @@ c write(*,*) 'begin zgbsvxx testing' CALL ZLACPY( 'Full', N, NRHS, BSAV, LDB, B, LDB ) IF( .NOT.PREFAC ) - $ CALL ZLASET( 'Full', 2*KL+KU+1, N, ZERO, ZERO, - $ AFB, LDAFB ) - CALL ZLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDB ) + $ CALL ZLASET( 'Full', 2*KL+KU+1, N, + $ DCMPLX( ZERO ), DCMPLX( ZERO ), + $ AFB, LDAFB ) + CALL ZLASET( 'Full', N, NRHS, + $ DCMPLX( ZERO ), DCMPLX( ZERO ), + $ X, LDB ) IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN * * Equilibrate the matrix if FACT = 'F' and @@ -778,7 +781,7 @@ c write(*,*) 'begin zgbsvxx testing' * residual. * CALL ZGBT01( N, N, KL, KU, A, LDA, AFB, LDAFB, - $ IWORK, RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + $ IWORK, WORK( 2*NRHS+1 ), RESULT( 1 ) ) K1 = 1 ELSE K1 = 2 @@ -792,8 +795,7 @@ c write(*,*) 'begin zgbsvxx testing' CALL ZLACPY( 'Full', N, NRHS, BSAV, LDB, WORK, $ LDB ) CALL ZGBT02( TRANS, N, N, KL, KU, NRHS, ASAV, - $ LDA, X, LDB, WORK, LDB, RWORK( 2*NRHS+1 ), - $ RESULT( 2 ) ) + $ LDA, X, LDB, WORK, LDB, RESULT( 2 ) ) * * Check solution from generated exact solution. * diff --git a/TESTING/LIN/zerrrfp.f b/TESTING/LIN/zerrrfp.f index 96b02dbd..078018c8 100644 --- a/TESTING/LIN/zerrrfp.f +++ b/TESTING/LIN/zerrrfp.f @@ -30,7 +30,8 @@ * .. * .. Local Scalars .. INTEGER INFO - COMPLEX*16 ALPHA, BETA + DOUBLE PRECISION ALPHA, BETA + COMPLEX*16 CALPHA * .. * .. Local Arrays .. COMPLEX*16 A( 1, 1), B( 1, 1) @@ -56,10 +57,11 @@ * NOUT = NUNIT OK = .TRUE. - A( 1, 1 ) = DCMPLX( 1.D0 , 1.D0 ) - B( 1, 1 ) = DCMPLX( 1.D0 , 1.D0 ) - ALPHA = DCMPLX( 1.D0 , 1.D0 ) - BETA = DCMPLX( 1.D0 , 1.D0 ) + A( 1, 1 ) = DCMPLX( 1.0D0 , 1.0D0 ) + B( 1, 1 ) = DCMPLX( 1.0D0 , 1.0D0 ) + ALPHA = 1.0D0 + CALPHA = DCMPLX( 1.0D0 , 1.0D0 ) + BETA = 1.0D0 * SRNAMT = 'ZPFTRF' INFOT = 1 @@ -102,28 +104,28 @@ * SRNAMT = 'ZTFSM ' INFOT = 1 - CALL ZTFSM( '/', 'L', 'U', 'C', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL ZTFSM( '/', 'L', 'U', 'C', 'U', 0, 0, CALPHA, A, B, 1 ) CALL CHKXER( 'ZTFSM ', INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL ZTFSM( 'N', '/', 'U', 'C', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL ZTFSM( 'N', '/', 'U', 'C', 'U', 0, 0, CALPHA, A, B, 1 ) CALL CHKXER( 'ZTFSM ', INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL ZTFSM( 'N', 'L', '/', 'C', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL ZTFSM( 'N', 'L', '/', 'C', 'U', 0, 0, CALPHA, A, B, 1 ) CALL CHKXER( 'ZTFSM ', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZTFSM( 'N', 'L', 'U', '/', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL ZTFSM( 'N', 'L', 'U', '/', 'U', 0, 0, CALPHA, A, B, 1 ) CALL CHKXER( 'ZTFSM ', INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZTFSM( 'N', 'L', 'U', 'C', '/', 0, 0, ALPHA, A, B, 1 ) + CALL ZTFSM( 'N', 'L', 'U', 'C', '/', 0, 0, CALPHA, A, B, 1 ) CALL CHKXER( 'ZTFSM ', INFOT, NOUT, LERR, OK ) INFOT = 6 - CALL ZTFSM( 'N', 'L', 'U', 'C', 'U', -1, 0, ALPHA, A, B, 1 ) + CALL ZTFSM( 'N', 'L', 'U', 'C', 'U', -1, 0, CALPHA, A, B, 1 ) CALL CHKXER( 'ZTFSM ', INFOT, NOUT, LERR, OK ) INFOT = 7 - CALL ZTFSM( 'N', 'L', 'U', 'C', 'U', 0, -1, ALPHA, A, B, 1 ) + CALL ZTFSM( 'N', 'L', 'U', 'C', 'U', 0, -1, CALPHA, A, B, 1 ) CALL CHKXER( 'ZTFSM ', INFOT, NOUT, LERR, OK ) INFOT = 11 - CALL ZTFSM( 'N', 'L', 'U', 'C', 'U', 0, 0, ALPHA, A, B, 0 ) + CALL ZTFSM( 'N', 'L', 'U', 'C', 'U', 0, 0, CALPHA, A, B, 0 ) CALL CHKXER( 'ZTFSM ', INFOT, NOUT, LERR, OK ) * SRNAMT = 'ZTFTRI' diff --git a/TESTING/MATGEN/claror.f b/TESTING/MATGEN/claror.f index f1648bef..d1d04d26 100644 --- a/TESTING/MATGEN/claror.f +++ b/TESTING/MATGEN/claror.f @@ -137,6 +137,7 @@ * .. * .. Executable Statements .. * + INFO = 0 IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * @@ -153,7 +154,6 @@ * * Check for argument errors. * - INFO = 0 IF( ITYPE.EQ.0 ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN diff --git a/TESTING/MATGEN/dlaror.f b/TESTING/MATGEN/dlaror.f index c844af7d..468e37cd 100644 --- a/TESTING/MATGEN/dlaror.f +++ b/TESTING/MATGEN/dlaror.f @@ -118,6 +118,7 @@ * .. * .. Executable Statements .. * + INFO = 0 IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * @@ -132,7 +133,6 @@ * * Check for argument errors. * - INFO = 0 IF( ITYPE.EQ.0 ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN diff --git a/TESTING/MATGEN/dlatm7.f b/TESTING/MATGEN/dlatm7.f index e21ad3c9..683d46be 100644 --- a/TESTING/MATGEN/dlatm7.f +++ b/TESTING/MATGEN/dlatm7.f @@ -184,7 +184,7 @@ * 160 CONTINUE D( 1 ) = ONE - IF( N.GT.1 ) THEN + IF( N.GT.1 .AND. RANK.GT.1 ) THEN ALPHA = COND**( -ONE / DBLE( RANK-1 ) ) DO 170 I = 2, RANK D( I ) = ALPHA**( I-1 ) diff --git a/TESTING/MATGEN/slaror.f b/TESTING/MATGEN/slaror.f index a18cdc10..4e5bef53 100644 --- a/TESTING/MATGEN/slaror.f +++ b/TESTING/MATGEN/slaror.f @@ -118,6 +118,7 @@ * .. * .. Executable Statements .. * + INFO = 0 IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * @@ -132,7 +133,6 @@ * * Check for argument errors. * - INFO = 0 IF( ITYPE.EQ.0 ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN diff --git a/TESTING/MATGEN/zlaror.f b/TESTING/MATGEN/zlaror.f index f739c7ec..73f75136 100644 --- a/TESTING/MATGEN/zlaror.f +++ b/TESTING/MATGEN/zlaror.f @@ -137,6 +137,7 @@ * .. * .. Executable Statements .. * + INFO = 0 IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * @@ -153,7 +154,6 @@ * * Check for argument errors. * - INFO = 0 IF( ITYPE.EQ.0 ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN |