diff --git a/lapack-netlib/SRC/chetf2.c b/lapack-netlib/SRC/chetf2.c index 70f2354ced..5b95f51e20 100644 --- a/lapack-netlib/SRC/chetf2.c +++ b/lapack-netlib/SRC/chetf2.c @@ -249,7 +249,6 @@ typedef struct Namelist Namelist; - /* Table of constant values */ static integer c__1 = 1; @@ -262,7 +261,6 @@ thod (unblocked algorithm calling Level 2 BLAS). */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download CHETF2 + dependencies */ /* > */ @@ -273,7 +271,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -383,9 +380,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complexHEcomputational */ +/* > \ingroup hetf2 */ /* > \par Further Details: */ /* ===================== */ @@ -445,45 +440,43 @@ f"> */ { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; - real r__1=0., r__2=0., r__3=0., r__4=0.; - complex q__1={0.,0.}, q__2={0.,0.}, q__3={0.,0.}, q__4={0.,0.}, q__5={0.,0.}, q__6={0.,0.}; + real r__1, r__2, r__3, r__4; + complex q__1, q__2, q__3, q__4, q__5, q__6; /* Local variables */ - extern /* Subroutine */ void cher_(char *, integer *, real *, complex *, - integer *, complex *, integer *); - integer imax, jmax; real d__; integer i__, j, k; complex t; + real r1, d11; + complex d12; + real d22; + complex d21; + integer kk, kp; + complex wk; + real tt; + complex wkm1, wkp1; + extern /* Subroutine */ void cher_(char *, integer *, real *, complex *, + integer *, complex *, integer *); + integer imax, jmax; real alpha; extern logical lsame_(char *, char *); extern /* Subroutine */ void cswap_(integer *, complex *, integer *, complex *, integer *); integer kstep; logical upper; - real r1, d11; - complex d12; - real d22; - complex d21; extern real slapy2_(real *, real *); - integer kk, kp; real absakk; - complex wk; extern integer icamax_(integer *, complex *, integer *); - real tt; extern /* Subroutine */ void csscal_(integer *, real *, complex *, integer - *); - extern void xerbla_(char *, integer *, ftnlen); + *), xerbla_(char *, integer *, ftnlen); real colmax; extern logical sisnan_(real *); real rowmax; - complex wkm1, wkp1; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -493,7 +486,7 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; @@ -729,27 +722,28 @@ f"> */ i__1 = k - 1 + k * a_dim1; q__1.r = a[i__1].r / d__, q__1.i = a[i__1].i / d__; d12.r = q__1.r, d12.i = q__1.i; - d__ = tt / d__; for (j = k - 2; j >= 1; --j) { i__1 = j + (k - 1) * a_dim1; - q__3.r = d11 * a[i__1].r, q__3.i = d11 * a[i__1].i; - r_cnjg(&q__5, &d12); + q__4.r = d11 * a[i__1].r, q__4.i = d11 * a[i__1].i; + r_cnjg(&q__6, &d12); i__2 = j + k * a_dim1; - q__4.r = q__5.r * a[i__2].r - q__5.i * a[i__2].i, - q__4.i = q__5.r * a[i__2].i + q__5.i * a[i__2] + q__5.r = q__6.r * a[i__2].r - q__6.i * a[i__2].i, + q__5.i = q__6.r * a[i__2].i + q__6.i * a[i__2] .r; - q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; - q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i; + q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i; + q__2.r = q__3.r / d__, q__2.i = q__3.i / d__; + q__1.r = tt * q__2.r, q__1.i = tt * q__2.i; wkm1.r = q__1.r, wkm1.i = q__1.i; i__1 = j + k * a_dim1; - q__3.r = d22 * a[i__1].r, q__3.i = d22 * a[i__1].i; + q__4.r = d22 * a[i__1].r, q__4.i = d22 * a[i__1].i; i__2 = j + (k - 1) * a_dim1; - q__4.r = d12.r * a[i__2].r - d12.i * a[i__2].i, - q__4.i = d12.r * a[i__2].i + d12.i * a[i__2] + q__5.r = d12.r * a[i__2].r - d12.i * a[i__2].i, + q__5.i = d12.r * a[i__2].i + d12.i * a[i__2] .r; - q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; - q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i; + q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i; + q__2.r = q__3.r / d__, q__2.i = q__3.i / d__; + q__1.r = tt * q__2.r, q__1.i = tt * q__2.i; wk.r = q__1.r, wk.i = q__1.i; for (i__ = j; i__ >= 1; --i__) { i__1 = i__ + j * a_dim1; @@ -1017,28 +1011,29 @@ f"> */ i__1 = k + 1 + k * a_dim1; q__1.r = a[i__1].r / d__, q__1.i = a[i__1].i / d__; d21.r = q__1.r, d21.i = q__1.i; - d__ = tt / d__; i__1 = *n; for (j = k + 2; j <= i__1; ++j) { i__2 = j + k * a_dim1; - q__3.r = d11 * a[i__2].r, q__3.i = d11 * a[i__2].i; + q__4.r = d11 * a[i__2].r, q__4.i = d11 * a[i__2].i; i__3 = j + (k + 1) * a_dim1; - q__4.r = d21.r * a[i__3].r - d21.i * a[i__3].i, - q__4.i = d21.r * a[i__3].i + d21.i * a[i__3] + q__5.r = d21.r * a[i__3].r - d21.i * a[i__3].i, + q__5.i = d21.r * a[i__3].i + d21.i * a[i__3] .r; - q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; - q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i; + q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i; + q__2.r = q__3.r / d__, q__2.i = q__3.i / d__; + q__1.r = tt * q__2.r, q__1.i = tt * q__2.i; wk.r = q__1.r, wk.i = q__1.i; i__2 = j + (k + 1) * a_dim1; - q__3.r = d22 * a[i__2].r, q__3.i = d22 * a[i__2].i; - r_cnjg(&q__5, &d21); + q__4.r = d22 * a[i__2].r, q__4.i = d22 * a[i__2].i; + r_cnjg(&q__6, &d21); i__3 = j + k * a_dim1; - q__4.r = q__5.r * a[i__3].r - q__5.i * a[i__3].i, - q__4.i = q__5.r * a[i__3].i + q__5.i * a[i__3] + q__5.r = q__6.r * a[i__3].r - q__6.i * a[i__3].i, + q__5.i = q__6.r * a[i__3].i + q__6.i * a[i__3] .r; - q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; - q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i; + q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i; + q__2.r = q__3.r / d__, q__2.i = q__3.i / d__; + q__1.r = tt * q__2.r, q__1.i = tt * q__2.i; wkp1.r = q__1.r, wkp1.i = q__1.i; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { diff --git a/lapack-netlib/SRC/chetf2.f b/lapack-netlib/SRC/chetf2.f index 84ba339fbb..28dcbd3c35 100644 --- a/lapack-netlib/SRC/chetf2.f +++ b/lapack-netlib/SRC/chetf2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CHETF2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -127,7 +125,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexHEcomputational +*> \ingroup hetf2 * *> \par Further Details: * ===================== @@ -183,6 +181,7 @@ *> * ===================================================================== SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -284,7 +283,8 @@ SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO ) COLMAX = ZERO END IF * - IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. + $ SISNAN(ABSAKK) ) THEN * * Column K is or underflow, or contains a NaN: * set INFO and continue @@ -403,11 +403,11 @@ SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO ) D11 = REAL( A( K, K ) ) / D TT = ONE / ( D11*D22-ONE ) D12 = A( K-1, K ) / D - D = TT / D * DO 40 J = K - 2, 1, -1 - WKM1 = D*( D11*A( J, K-1 )-CONJG( D12 )*A( J, K ) ) - WK = D*( D22*A( J, K )-D12*A( J, K-1 ) ) + WKM1 = TT*( ( D11*A( J, K-1 )-CONJG( D12 )* + $ A( J, K ) ) / D ) + WK = TT*( ( D22*A( J, K )-D12*A( J, K-1 ) ) / D ) DO 30 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*CONJG( WK ) - $ A( I, K-1 )*CONJG( WKM1 ) @@ -468,7 +468,8 @@ SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO ) COLMAX = ZERO END IF * - IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. + $ SISNAN(ABSAKK) ) THEN * * Column K is zero or underflow, contains a NaN: * set INFO and continue @@ -491,7 +492,8 @@ SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO ) JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), LDA ) ROWMAX = CABS1( A( IMAX, JMAX ) ) IF( IMAX.LT.N ) THEN - JMAX = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 ) + JMAX = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) ROWMAX = MAX( ROWMAX, CABS1( A( JMAX, IMAX ) ) ) END IF * @@ -524,7 +526,8 @@ SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO ) * submatrix A(k:n,k:n) * IF( KP.LT.N ) - $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) DO 60 J = KK + 1, KP - 1 T = CONJG( A( J, KK ) ) A( J, KK ) = CONJG( A( KP, J ) ) @@ -590,11 +593,11 @@ SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO ) D22 = REAL( A( K, K ) ) / D TT = ONE / ( D11*D22-ONE ) D21 = A( K+1, K ) / D - D = TT / D * DO 80 J = K + 2, N - WK = D*( D11*A( J, K )-D21*A( J, K+1 ) ) - WKP1 = D*( D22*A( J, K+1 )-CONJG( D21 )*A( J, K ) ) + WK = TT*( ( D11*A( J, K )-D21*A( J, K+1 ) ) / D ) + WKP1 = TT*( ( D22*A( J, K+1 )-CONJG( D21 )* + $ A( J, K ) ) / D ) DO 70 I = J, N A( I, J ) = A( I, J ) - A( I, K )*CONJG( WK ) - $ A( I, K+1 )*CONJG( WKP1 ) diff --git a/lapack-netlib/SRC/chetf2_rk.c b/lapack-netlib/SRC/chetf2_rk.c index be93ac70ba..52c02a04ff 100644 --- a/lapack-netlib/SRC/chetf2_rk.c +++ b/lapack-netlib/SRC/chetf2_rk.c @@ -182,14 +182,14 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define r_imag(z) (cimagf(Cf(z))) #define c_abs(z) (cabsf(Cf(z))) #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } #ifdef _MSC_VER #define c_div(c, a, b) {float nenn=crealf(_FCmulcc(Cf(b),conjf(Cf(b)))); _Fcomplex zaehl=_FCmulcc(Cf(a),conjf(Cf(b))); pCf(c)=_FCbuild(crealf(zaehl)/nenn,cimagf(zaehl)/nenn);} -#define z_div(c, a, b) {double nenn=creal(_Cmulcc(Cd(b),conj(Cd(b)))); _Dcomplex zaehl=_Cmulcc(Cd(a),conj(Cd(b))); pCd(c)=_Cbuild(creal(zaehl)/nenn,cimag(zaehl)/nenn);} #else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} #endif #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} @@ -201,14 +201,10 @@ typedef struct Namelist Namelist; #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -234,9 +230,6 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } @@ -256,7 +249,6 @@ typedef struct Namelist Namelist; - /* Table of constant values */ static integer c__1 = 1; @@ -269,7 +261,6 @@ static integer c__1 = 1; /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download CHETF2_RK + dependencies */ /* > */ @@ -280,7 +271,6 @@ rk.f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -471,9 +461,7 @@ rk.f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complexHEcomputational */ +/* > \ingroup hetf2_rk */ /* > \par Further Details: */ /* ===================== */ @@ -507,17 +495,25 @@ rk.f"> */ { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; - real r__1=0., r__2=0.; - complex q__1={0.,0.}, q__2={0.,0.}, q__3={0.,0.}, q__4={0.,0.}, q__5={0.,0.}, q__6={0.,0.}, q__7={0.,0.}, q__8={0.,0.}; + real r__1, r__2; + complex q__1, q__2, q__3, q__4, q__5, q__6; /* Local variables */ + real d__; + integer i__, j, k, p; + complex t; + real r1, d11; + complex d12; + real d22; + complex d21; + integer ii, kk, kp; + complex wk; + real tt; + complex wkm1, wkp1; extern /* Subroutine */ void cher_(char *, integer *, real *, complex *, integer *, complex *, integer *); logical done; integer imax, jmax; - real d__; - integer i__, j, k, p; - complex t; real alpha; extern logical lsame_(char *, char *); real sfmin; @@ -526,28 +522,18 @@ rk.f"> */ integer itemp, kstep; real stemp; logical upper; - real r1, d11; - complex d12; - real d22; - complex d21; extern real slapy2_(real *, real *); - integer ii, kk, kp; real absakk; - complex wk; extern integer icamax_(integer *, complex *, integer *); extern real slamch_(char *); - real tt; extern /* Subroutine */ void csscal_(integer *, real *, complex *, integer - *); - extern void xerbla_(char *, integer *, ftnlen); + *), xerbla_(char *, integer *, ftnlen); real colmax, rowmax; - complex wkm1, wkp1; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ====================================================================== */ @@ -558,7 +544,7 @@ rk.f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --e; --ipiv; @@ -779,7 +765,7 @@ rk.f"> */ a[i__2].r = t.r, a[i__2].i = t.i; /* L14: */ } -/* (3) Swap and conjugate corner elements at row-col interserction */ +/* (3) Swap and conjugate corner elements at row-col intersection */ i__1 = p + k * a_dim1; r_cnjg(&q__1, &a[p + k * a_dim1]); a[i__1].r = q__1.r, a[i__1].i = q__1.i; @@ -826,7 +812,7 @@ rk.f"> */ a[i__2].r = t.r, a[i__2].i = t.i; /* L15: */ } -/* (3) Swap and conjugate corner elements at row-col interserction */ +/* (3) Swap and conjugate corner elements at row-col intersection */ i__1 = kp + kk * a_dim1; r_cnjg(&q__1, &a[kp + kk * a_dim1]); a[i__1].r = q__1.r, a[i__1].i = q__1.i; @@ -981,25 +967,27 @@ rk.f"> */ for (j = k - 2; j >= 1; --j) { -/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ +/* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J */ i__1 = j + (k - 1) * a_dim1; - q__3.r = d11 * a[i__1].r, q__3.i = d11 * a[i__1].i; - r_cnjg(&q__5, &d12); + q__4.r = d11 * a[i__1].r, q__4.i = d11 * a[i__1].i; + r_cnjg(&q__6, &d12); i__2 = j + k * a_dim1; - q__4.r = q__5.r * a[i__2].r - q__5.i * a[i__2].i, - q__4.i = q__5.r * a[i__2].i + q__5.i * a[i__2] + q__5.r = q__6.r * a[i__2].r - q__6.i * a[i__2].i, + q__5.i = q__6.r * a[i__2].i + q__6.i * a[i__2] .r; - q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; + q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i; + q__2.r = q__3.r / d__, q__2.i = q__3.i / d__; q__1.r = tt * q__2.r, q__1.i = tt * q__2.i; wkm1.r = q__1.r, wkm1.i = q__1.i; i__1 = j + k * a_dim1; - q__3.r = d22 * a[i__1].r, q__3.i = d22 * a[i__1].i; + q__4.r = d22 * a[i__1].r, q__4.i = d22 * a[i__1].i; i__2 = j + (k - 1) * a_dim1; - q__4.r = d12.r * a[i__2].r - d12.i * a[i__2].i, - q__4.i = d12.r * a[i__2].i + d12.i * a[i__2] + q__5.r = d12.r * a[i__2].r - d12.i * a[i__2].i, + q__5.i = d12.r * a[i__2].i + d12.i * a[i__2] .r; - q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; + q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i; + q__2.r = q__3.r / d__, q__2.i = q__3.i / d__; q__1.r = tt * q__2.r, q__1.i = tt * q__2.i; wk.r = q__1.r, wk.i = q__1.i; @@ -1009,23 +997,19 @@ rk.f"> */ i__1 = i__ + j * a_dim1; i__2 = i__ + j * a_dim1; i__3 = i__ + k * a_dim1; - q__4.r = a[i__3].r / d__, q__4.i = a[i__3].i / - d__; - r_cnjg(&q__5, &wk); - q__3.r = q__4.r * q__5.r - q__4.i * q__5.i, - q__3.i = q__4.r * q__5.i + q__4.i * - q__5.r; + r_cnjg(&q__4, &wk); + q__3.r = a[i__3].r * q__4.r - a[i__3].i * q__4.i, + q__3.i = a[i__3].r * q__4.i + a[i__3].i * + q__4.r; q__2.r = a[i__2].r - q__3.r, q__2.i = a[i__2].i - q__3.i; i__4 = i__ + (k - 1) * a_dim1; - q__7.r = a[i__4].r / d__, q__7.i = a[i__4].i / - d__; - r_cnjg(&q__8, &wkm1); - q__6.r = q__7.r * q__8.r - q__7.i * q__8.i, - q__6.i = q__7.r * q__8.i + q__7.i * - q__8.r; - q__1.r = q__2.r - q__6.r, q__1.i = q__2.i - - q__6.i; + r_cnjg(&q__6, &wkm1); + q__5.r = a[i__4].r * q__6.r - a[i__4].i * q__6.i, + q__5.i = a[i__4].r * q__6.i + a[i__4].i * + q__6.r; + q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - + q__5.i; a[i__1].r = q__1.r, a[i__1].i = q__1.i; /* L20: */ } @@ -1033,11 +1017,9 @@ rk.f"> */ /* Store U(k) and U(k-1) in cols k and k-1 for row J */ i__1 = j + k * a_dim1; - q__1.r = wk.r / d__, q__1.i = wk.i / d__; - a[i__1].r = q__1.r, a[i__1].i = q__1.i; + a[i__1].r = wk.r, a[i__1].i = wk.i; i__1 = j + (k - 1) * a_dim1; - q__1.r = wkm1.r / d__, q__1.i = wkm1.i / d__; - a[i__1].r = q__1.r, a[i__1].i = q__1.i; + a[i__1].r = wkm1.r, a[i__1].i = wkm1.i; /* (*) Make sure that diagonal element of pivot is real */ i__1 = j + j * a_dim1; i__2 = j + j * a_dim1; @@ -1277,7 +1259,7 @@ rk.f"> */ a[i__2].r = t.r, a[i__2].i = t.i; /* L44: */ } -/* (3) Swap and conjugate corner elements at row-col interserction */ +/* (3) Swap and conjugate corner elements at row-col intersection */ i__1 = p + k * a_dim1; r_cnjg(&q__1, &a[p + k * a_dim1]); a[i__1].r = q__1.r, a[i__1].i = q__1.i; @@ -1323,7 +1305,7 @@ rk.f"> */ a[i__2].r = t.r, a[i__2].i = t.i; /* L45: */ } -/* (3) Swap and conjugate corner elements at row-col interserction */ +/* (3) Swap and conjugate corner elements at row-col intersection */ i__1 = kp + kk * a_dim1; r_cnjg(&q__1, &a[kp + kk * a_dim1]); a[i__1].r = q__1.r, a[i__1].i = q__1.i; @@ -1479,25 +1461,27 @@ rk.f"> */ i__1 = *n; for (j = k + 2; j <= i__1; ++j) { -/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ +/* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J */ i__2 = j + k * a_dim1; - q__3.r = d11 * a[i__2].r, q__3.i = d11 * a[i__2].i; + q__4.r = d11 * a[i__2].r, q__4.i = d11 * a[i__2].i; i__3 = j + (k + 1) * a_dim1; - q__4.r = d21.r * a[i__3].r - d21.i * a[i__3].i, - q__4.i = d21.r * a[i__3].i + d21.i * a[i__3] + q__5.r = d21.r * a[i__3].r - d21.i * a[i__3].i, + q__5.i = d21.r * a[i__3].i + d21.i * a[i__3] .r; - q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; + q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i; + q__2.r = q__3.r / d__, q__2.i = q__3.i / d__; q__1.r = tt * q__2.r, q__1.i = tt * q__2.i; wk.r = q__1.r, wk.i = q__1.i; i__2 = j + (k + 1) * a_dim1; - q__3.r = d22 * a[i__2].r, q__3.i = d22 * a[i__2].i; - r_cnjg(&q__5, &d21); + q__4.r = d22 * a[i__2].r, q__4.i = d22 * a[i__2].i; + r_cnjg(&q__6, &d21); i__3 = j + k * a_dim1; - q__4.r = q__5.r * a[i__3].r - q__5.i * a[i__3].i, - q__4.i = q__5.r * a[i__3].i + q__5.i * a[i__3] + q__5.r = q__6.r * a[i__3].r - q__6.i * a[i__3].i, + q__5.i = q__6.r * a[i__3].i + q__6.i * a[i__3] .r; - q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; + q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i; + q__2.r = q__3.r / d__, q__2.i = q__3.i / d__; q__1.r = tt * q__2.r, q__1.i = tt * q__2.i; wkp1.r = q__1.r, wkp1.i = q__1.i; @@ -1508,23 +1492,19 @@ rk.f"> */ i__3 = i__ + j * a_dim1; i__4 = i__ + j * a_dim1; i__5 = i__ + k * a_dim1; - q__4.r = a[i__5].r / d__, q__4.i = a[i__5].i / - d__; - r_cnjg(&q__5, &wk); - q__3.r = q__4.r * q__5.r - q__4.i * q__5.i, - q__3.i = q__4.r * q__5.i + q__4.i * - q__5.r; + r_cnjg(&q__4, &wk); + q__3.r = a[i__5].r * q__4.r - a[i__5].i * q__4.i, + q__3.i = a[i__5].r * q__4.i + a[i__5].i * + q__4.r; q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i - q__3.i; i__6 = i__ + (k + 1) * a_dim1; - q__7.r = a[i__6].r / d__, q__7.i = a[i__6].i / - d__; - r_cnjg(&q__8, &wkp1); - q__6.r = q__7.r * q__8.r - q__7.i * q__8.i, - q__6.i = q__7.r * q__8.i + q__7.i * - q__8.r; - q__1.r = q__2.r - q__6.r, q__1.i = q__2.i - - q__6.i; + r_cnjg(&q__6, &wkp1); + q__5.r = a[i__6].r * q__6.r - a[i__6].i * q__6.i, + q__5.i = a[i__6].r * q__6.i + a[i__6].i * + q__6.r; + q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - + q__5.i; a[i__3].r = q__1.r, a[i__3].i = q__1.i; /* L50: */ } @@ -1532,11 +1512,9 @@ rk.f"> */ /* Store L(k) and L(k+1) in cols k and k+1 for row J */ i__2 = j + k * a_dim1; - q__1.r = wk.r / d__, q__1.i = wk.i / d__; - a[i__2].r = q__1.r, a[i__2].i = q__1.i; + a[i__2].r = wk.r, a[i__2].i = wk.i; i__2 = j + (k + 1) * a_dim1; - q__1.r = wkp1.r / d__, q__1.i = wkp1.i / d__; - a[i__2].r = q__1.r, a[i__2].i = q__1.i; + a[i__2].r = wkp1.r, a[i__2].i = wkp1.i; /* (*) Make sure that diagonal element of pivot is real */ i__2 = j + j * a_dim1; i__3 = j + j * a_dim1; diff --git a/lapack-netlib/SRC/chetf2_rk.f b/lapack-netlib/SRC/chetf2_rk.f index e687ec64a8..bcd8e1d0b4 100644 --- a/lapack-netlib/SRC/chetf2_rk.f +++ b/lapack-netlib/SRC/chetf2_rk.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CHETF2_RK + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -208,7 +206,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexHEcomputational +*> \ingroup hetf2_rk * *> \par Further Details: * ===================== @@ -238,6 +236,7 @@ * * ===================================================================== SUBROUTINE CHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -491,7 +490,8 @@ SUBROUTINE CHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * the interchanges in columns k+1:N. * IF( K.LT.N ) - $ CALL CSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA ) + $ CALL CSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), + $ LDA ) * END IF * @@ -560,7 +560,8 @@ SUBROUTINE CHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * = A - W(k)*1/D(k)*W(k)**T * D11 = ONE / REAL( A( K, K ) ) - CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) * * Store U(k) in column k * @@ -579,7 +580,8 @@ SUBROUTINE CHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * = A - W(k)*(1/D(k))*W(k)**T * = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T * - CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) END IF * * Store the superdiagonal element of D in array E @@ -615,24 +617,24 @@ SUBROUTINE CHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WKM1 = TT*( D11*A( J, K-1 )-CONJG( D12 )* - $ A( J, K ) ) - WK = TT*( D22*A( J, K )-D12*A( J, K-1 ) ) + WKM1 = TT*( ( D11*A( J, K-1 )-CONJG( D12 )* + $ A( J, K ) ) / D ) + WK = TT*( ( D22*A( J, K )-D12*A( J, K-1 ) ) / D ) * * Perform a rank-2 update of A(1:k-2,1:k-2) * DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - - $ ( A( I, K ) / D )*CONJG( WK ) - - $ ( A( I, K-1 ) / D )*CONJG( WKM1 ) + $ A( I, K )*CONJG( WK ) - + $ A( I, K-1 )*CONJG( WKM1 ) 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D - A( J, K-1 ) = WKM1 / D + A( J, K ) = WK + A( J, K-1 ) = WKM1 * (*) Make sure that diagonal element of pivot is real A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO ) * @@ -752,14 +754,16 @@ SUBROUTINE CHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * Determine both ROWMAX and JMAX. * IF( IMAX.NE.K ) THEN - JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), LDA ) + JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), + $ LDA ) ROWMAX = CABS1( A( IMAX, JMAX ) ) ELSE ROWMAX = ZERO END IF * IF( IMAX.LT.N ) THEN - ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ), + ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, + $ IMAX ), $ 1 ) STEMP = CABS1( A( ITEMP, IMAX ) ) IF( STEMP.GT.ROWMAX ) THEN @@ -855,7 +859,8 @@ SUBROUTINE CHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) IF( KP.NE.KK ) THEN * (1) Swap columnar parts IF( KP.LT.N ) - $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) * (2) Swap and conjugate middle parts DO 45 J = KK + 1, KP - 1 T = CONJG( A( J, KK ) ) @@ -973,24 +978,24 @@ SUBROUTINE CHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = TT*( D11*A( J, K )-D21*A( J, K+1 ) ) - WKP1 = TT*( D22*A( J, K+1 )-CONJG( D21 )* - $ A( J, K ) ) + WK = TT*( ( D11*A( J, K )-D21*A( J, K+1 ) ) / D ) + WKP1 = TT*( ( D22*A( J, K+1 )-CONJG( D21 )* + $ A( J, K ) ) / D ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N A( I, J ) = A( I, J ) - - $ ( A( I, K ) / D )*CONJG( WK ) - - $ ( A( I, K+1 ) / D )*CONJG( WKP1 ) + $ A( I, K )*CONJG( WK ) - + $ A( I, K+1 )*CONJG( WKP1 ) 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D - A( J, K+1 ) = WKP1 / D + A( J, K ) = WK + A( J, K+1 ) = WKP1 * (*) Make sure that diagonal element of pivot is real A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO ) * diff --git a/lapack-netlib/SRC/chetf2_rook.c b/lapack-netlib/SRC/chetf2_rook.c index baaa00015a..544b4adbf9 100644 --- a/lapack-netlib/SRC/chetf2_rook.c +++ b/lapack-netlib/SRC/chetf2_rook.c @@ -182,14 +182,14 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define r_imag(z) (cimagf(Cf(z))) #define c_abs(z) (cabsf(Cf(z))) #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } #ifdef _MSC_VER #define c_div(c, a, b) {float nenn=crealf(_FCmulcc(Cf(b),conjf(Cf(b)))); _Fcomplex zaehl=_FCmulcc(Cf(a),conjf(Cf(b))); pCf(c)=_FCbuild(crealf(zaehl)/nenn,cimagf(zaehl)/nenn);} -#define z_div(c, a, b) {double nenn=creal(_Cmulcc(Cd(b),conj(Cd(b)))); _Dcomplex zaehl=_Cmulcc(Cd(a),conj(Cd(b))); pCd(c)=_Cbuild(creal(zaehl)/nenn,cimag(zaehl)/nenn);} #else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} #endif #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} @@ -201,14 +201,10 @@ typedef struct Namelist Namelist; #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -234,9 +230,6 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } @@ -256,7 +249,6 @@ typedef struct Namelist Namelist; - /* Table of constant values */ static integer c__1 = 1; @@ -269,7 +261,6 @@ ed Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm). */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download CHETF2_ROOK + dependencies */ /* > */ @@ -280,7 +271,6 @@ rook.f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -392,9 +382,7 @@ rook.f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date November 2013 */ - -/* > \ingroup complexHEcomputational */ +/* > \ingroup hetf2_rook */ /* > \par Further Details: */ /* ===================== */ @@ -460,17 +448,25 @@ rook.f"> */ { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; - real r__1=0., r__2=0.; - complex q__1={0.,0.}, q__2={0.,0.}, q__3={0.,0.}, q__4={0.,0.}, q__5={0.,0.}, q__6={0.,0.}, q__7={0.,0.}, q__8={0.,0.}; + real r__1, r__2; + complex q__1, q__2, q__3, q__4, q__5, q__6; /* Local variables */ + real d__; + integer i__, j, k, p; + complex t; + real r1, d11; + complex d12; + real d22; + complex d21; + integer ii, kk, kp; + complex wk; + real tt; + complex wkm1, wkp1; extern /* Subroutine */ void cher_(char *, integer *, real *, complex *, integer *, complex *, integer *); logical done; integer imax, jmax; - real d__; - integer i__, j, k, p; - complex t; real alpha; extern logical lsame_(char *, char *); real sfmin; @@ -479,28 +475,18 @@ rook.f"> */ integer itemp, kstep; real stemp; logical upper; - real r1, d11; - complex d12; - real d22; - complex d21; extern real slapy2_(real *, real *); - integer ii, kk, kp; real absakk; - complex wk; extern integer icamax_(integer *, complex *, integer *); extern real slamch_(char *); - real tt; extern /* Subroutine */ void csscal_(integer *, real *, complex *, integer - *); - extern void xerbla_(char *, integer *, ftnlen); + *), xerbla_(char *, integer *, ftnlen); real colmax, rowmax; - complex wkm1, wkp1; -/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* November 2013 */ /* ====================================================================== */ @@ -511,7 +497,7 @@ rook.f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; @@ -718,7 +704,7 @@ rook.f"> */ a[i__2].r = t.r, a[i__2].i = t.i; /* L14: */ } -/* (3) Swap and conjugate corner elements at row-col interserction */ +/* (3) Swap and conjugate corner elements at row-col intersection */ i__1 = p + k * a_dim1; r_cnjg(&q__1, &a[p + k * a_dim1]); a[i__1].r = q__1.r, a[i__1].i = q__1.i; @@ -755,7 +741,7 @@ rook.f"> */ a[i__2].r = t.r, a[i__2].i = t.i; /* L15: */ } -/* (3) Swap and conjugate corner elements at row-col interserction */ +/* (3) Swap and conjugate corner elements at row-col intersection */ i__1 = kp + kk * a_dim1; r_cnjg(&q__1, &a[kp + kk * a_dim1]); a[i__1].r = q__1.r, a[i__1].i = q__1.i; @@ -894,25 +880,27 @@ rook.f"> */ for (j = k - 2; j >= 1; --j) { -/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ +/* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J */ i__1 = j + (k - 1) * a_dim1; - q__3.r = d11 * a[i__1].r, q__3.i = d11 * a[i__1].i; - r_cnjg(&q__5, &d12); + q__4.r = d11 * a[i__1].r, q__4.i = d11 * a[i__1].i; + r_cnjg(&q__6, &d12); i__2 = j + k * a_dim1; - q__4.r = q__5.r * a[i__2].r - q__5.i * a[i__2].i, - q__4.i = q__5.r * a[i__2].i + q__5.i * a[i__2] + q__5.r = q__6.r * a[i__2].r - q__6.i * a[i__2].i, + q__5.i = q__6.r * a[i__2].i + q__6.i * a[i__2] .r; - q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; + q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i; + q__2.r = q__3.r / d__, q__2.i = q__3.i / d__; q__1.r = tt * q__2.r, q__1.i = tt * q__2.i; wkm1.r = q__1.r, wkm1.i = q__1.i; i__1 = j + k * a_dim1; - q__3.r = d22 * a[i__1].r, q__3.i = d22 * a[i__1].i; + q__4.r = d22 * a[i__1].r, q__4.i = d22 * a[i__1].i; i__2 = j + (k - 1) * a_dim1; - q__4.r = d12.r * a[i__2].r - d12.i * a[i__2].i, - q__4.i = d12.r * a[i__2].i + d12.i * a[i__2] + q__5.r = d12.r * a[i__2].r - d12.i * a[i__2].i, + q__5.i = d12.r * a[i__2].i + d12.i * a[i__2] .r; - q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; + q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i; + q__2.r = q__3.r / d__, q__2.i = q__3.i / d__; q__1.r = tt * q__2.r, q__1.i = tt * q__2.i; wk.r = q__1.r, wk.i = q__1.i; @@ -922,23 +910,19 @@ rook.f"> */ i__1 = i__ + j * a_dim1; i__2 = i__ + j * a_dim1; i__3 = i__ + k * a_dim1; - q__4.r = a[i__3].r / d__, q__4.i = a[i__3].i / - d__; - r_cnjg(&q__5, &wk); - q__3.r = q__4.r * q__5.r - q__4.i * q__5.i, - q__3.i = q__4.r * q__5.i + q__4.i * - q__5.r; + r_cnjg(&q__4, &wk); + q__3.r = a[i__3].r * q__4.r - a[i__3].i * q__4.i, + q__3.i = a[i__3].r * q__4.i + a[i__3].i * + q__4.r; q__2.r = a[i__2].r - q__3.r, q__2.i = a[i__2].i - q__3.i; i__4 = i__ + (k - 1) * a_dim1; - q__7.r = a[i__4].r / d__, q__7.i = a[i__4].i / - d__; - r_cnjg(&q__8, &wkm1); - q__6.r = q__7.r * q__8.r - q__7.i * q__8.i, - q__6.i = q__7.r * q__8.i + q__7.i * - q__8.r; - q__1.r = q__2.r - q__6.r, q__1.i = q__2.i - - q__6.i; + r_cnjg(&q__6, &wkm1); + q__5.r = a[i__4].r * q__6.r - a[i__4].i * q__6.i, + q__5.i = a[i__4].r * q__6.i + a[i__4].i * + q__6.r; + q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - + q__5.i; a[i__1].r = q__1.r, a[i__1].i = q__1.i; /* L20: */ } @@ -946,11 +930,9 @@ rook.f"> */ /* Store U(k) and U(k-1) in cols k and k-1 for row J */ i__1 = j + k * a_dim1; - q__1.r = wk.r / d__, q__1.i = wk.i / d__; - a[i__1].r = q__1.r, a[i__1].i = q__1.i; + a[i__1].r = wk.r, a[i__1].i = wk.i; i__1 = j + (k - 1) * a_dim1; - q__1.r = wkm1.r / d__, q__1.i = wkm1.i / d__; - a[i__1].r = q__1.r, a[i__1].i = q__1.i; + a[i__1].r = wkm1.r, a[i__1].i = wkm1.i; /* (*) Make sure that diagonal element of pivot is real */ i__1 = j + j * a_dim1; i__2 = j + j * a_dim1; @@ -1161,7 +1143,7 @@ rook.f"> */ a[i__2].r = t.r, a[i__2].i = t.i; /* L44: */ } -/* (3) Swap and conjugate corner elements at row-col interserction */ +/* (3) Swap and conjugate corner elements at row-col intersection */ i__1 = p + k * a_dim1; r_cnjg(&q__1, &a[p + k * a_dim1]); a[i__1].r = q__1.r, a[i__1].i = q__1.i; @@ -1198,7 +1180,7 @@ rook.f"> */ a[i__2].r = t.r, a[i__2].i = t.i; /* L45: */ } -/* (3) Swap and conjugate corner elements at row-col interserction */ +/* (3) Swap and conjugate corner elements at row-col intersection */ i__1 = kp + kk * a_dim1; r_cnjg(&q__1, &a[kp + kk * a_dim1]); a[i__1].r = q__1.r, a[i__1].i = q__1.i; @@ -1339,25 +1321,27 @@ rook.f"> */ i__1 = *n; for (j = k + 2; j <= i__1; ++j) { -/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ +/* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J */ i__2 = j + k * a_dim1; - q__3.r = d11 * a[i__2].r, q__3.i = d11 * a[i__2].i; + q__4.r = d11 * a[i__2].r, q__4.i = d11 * a[i__2].i; i__3 = j + (k + 1) * a_dim1; - q__4.r = d21.r * a[i__3].r - d21.i * a[i__3].i, - q__4.i = d21.r * a[i__3].i + d21.i * a[i__3] + q__5.r = d21.r * a[i__3].r - d21.i * a[i__3].i, + q__5.i = d21.r * a[i__3].i + d21.i * a[i__3] .r; - q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; + q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i; + q__2.r = q__3.r / d__, q__2.i = q__3.i / d__; q__1.r = tt * q__2.r, q__1.i = tt * q__2.i; wk.r = q__1.r, wk.i = q__1.i; i__2 = j + (k + 1) * a_dim1; - q__3.r = d22 * a[i__2].r, q__3.i = d22 * a[i__2].i; - r_cnjg(&q__5, &d21); + q__4.r = d22 * a[i__2].r, q__4.i = d22 * a[i__2].i; + r_cnjg(&q__6, &d21); i__3 = j + k * a_dim1; - q__4.r = q__5.r * a[i__3].r - q__5.i * a[i__3].i, - q__4.i = q__5.r * a[i__3].i + q__5.i * a[i__3] + q__5.r = q__6.r * a[i__3].r - q__6.i * a[i__3].i, + q__5.i = q__6.r * a[i__3].i + q__6.i * a[i__3] .r; - q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; + q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i; + q__2.r = q__3.r / d__, q__2.i = q__3.i / d__; q__1.r = tt * q__2.r, q__1.i = tt * q__2.i; wkp1.r = q__1.r, wkp1.i = q__1.i; @@ -1368,23 +1352,19 @@ rook.f"> */ i__3 = i__ + j * a_dim1; i__4 = i__ + j * a_dim1; i__5 = i__ + k * a_dim1; - q__4.r = a[i__5].r / d__, q__4.i = a[i__5].i / - d__; - r_cnjg(&q__5, &wk); - q__3.r = q__4.r * q__5.r - q__4.i * q__5.i, - q__3.i = q__4.r * q__5.i + q__4.i * - q__5.r; + r_cnjg(&q__4, &wk); + q__3.r = a[i__5].r * q__4.r - a[i__5].i * q__4.i, + q__3.i = a[i__5].r * q__4.i + a[i__5].i * + q__4.r; q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i - q__3.i; i__6 = i__ + (k + 1) * a_dim1; - q__7.r = a[i__6].r / d__, q__7.i = a[i__6].i / - d__; - r_cnjg(&q__8, &wkp1); - q__6.r = q__7.r * q__8.r - q__7.i * q__8.i, - q__6.i = q__7.r * q__8.i + q__7.i * - q__8.r; - q__1.r = q__2.r - q__6.r, q__1.i = q__2.i - - q__6.i; + r_cnjg(&q__6, &wkp1); + q__5.r = a[i__6].r * q__6.r - a[i__6].i * q__6.i, + q__5.i = a[i__6].r * q__6.i + a[i__6].i * + q__6.r; + q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - + q__5.i; a[i__3].r = q__1.r, a[i__3].i = q__1.i; /* L50: */ } @@ -1392,11 +1372,9 @@ rook.f"> */ /* Store L(k) and L(k+1) in cols k and k+1 for row J */ i__2 = j + k * a_dim1; - q__1.r = wk.r / d__, q__1.i = wk.i / d__; - a[i__2].r = q__1.r, a[i__2].i = q__1.i; + a[i__2].r = wk.r, a[i__2].i = wk.i; i__2 = j + (k + 1) * a_dim1; - q__1.r = wkp1.r / d__, q__1.i = wkp1.i / d__; - a[i__2].r = q__1.r, a[i__2].i = q__1.i; + a[i__2].r = wkp1.r, a[i__2].i = wkp1.i; /* (*) Make sure that diagonal element of pivot is real */ i__2 = j + j * a_dim1; i__3 = j + j * a_dim1; diff --git a/lapack-netlib/SRC/chetf2_rook.f b/lapack-netlib/SRC/chetf2_rook.f index 49fba1bda1..fcaef09229 100644 --- a/lapack-netlib/SRC/chetf2_rook.f +++ b/lapack-netlib/SRC/chetf2_rook.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CHETF2_ROOK + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -129,7 +127,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexHEcomputational +*> \ingroup hetf2_rook * *> \par Further Details: * ===================== @@ -191,6 +189,7 @@ * * ===================================================================== SUBROUTINE CHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -485,7 +484,8 @@ SUBROUTINE CHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * = A - W(k)*1/D(k)*W(k)**T * D11 = ONE / REAL( A( K, K ) ) - CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) * * Store U(k) in column k * @@ -504,7 +504,8 @@ SUBROUTINE CHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * = A - W(k)*(1/D(k))*W(k)**T * = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T * - CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) END IF END IF * @@ -535,24 +536,24 @@ SUBROUTINE CHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WKM1 = TT*( D11*A( J, K-1 )-CONJG( D12 )* - $ A( J, K ) ) - WK = TT*( D22*A( J, K )-D12*A( J, K-1 ) ) + WKM1 = TT*( ( D11*A( J, K-1 )-CONJG( D12 )* + $ A( J, K ) ) / D ) + WK = TT*( ( D22*A( J, K )-D12*A( J, K-1 ) ) / D ) * * Perform a rank-2 update of A(1:k-2,1:k-2) * DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - - $ ( A( I, K ) / D )*CONJG( WK ) - - $ ( A( I, K-1 ) / D )*CONJG( WKM1 ) + $ A( I, K )*CONJG( WK ) - + $ A( I, K-1 )*CONJG( WKM1 ) 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D - A( J, K-1 ) = WKM1 / D + A( J, K ) = WK + A( J, K-1 ) = WKM1 * (*) Make sure that diagonal element of pivot is real A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO ) * @@ -651,14 +652,16 @@ SUBROUTINE CHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * Determine both ROWMAX and JMAX. * IF( IMAX.NE.K ) THEN - JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), LDA ) + JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), + $ LDA ) ROWMAX = CABS1( A( IMAX, JMAX ) ) ELSE ROWMAX = ZERO END IF * IF( IMAX.LT.N ) THEN - ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ), + ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, + $ IMAX ), $ 1 ) STEMP = CABS1( A( ITEMP, IMAX ) ) IF( STEMP.GT.ROWMAX ) THEN @@ -747,7 +750,8 @@ SUBROUTINE CHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) IF( KP.NE.KK ) THEN * (1) Swap columnar parts IF( KP.LT.N ) - $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) * (2) Swap and conjugate middle parts DO 45 J = KK + 1, KP - 1 T = CONJG( A( J, KK ) ) @@ -853,24 +857,24 @@ SUBROUTINE CHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = TT*( D11*A( J, K )-D21*A( J, K+1 ) ) - WKP1 = TT*( D22*A( J, K+1 )-CONJG( D21 )* - $ A( J, K ) ) + WK = TT*( ( D11*A( J, K )-D21*A( J, K+1 ) ) / D ) + WKP1 = TT*( ( D22*A( J, K+1 )-CONJG( D21 )* + $ A( J, K ) ) / D ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N A( I, J ) = A( I, J ) - - $ ( A( I, K ) / D )*CONJG( WK ) - - $ ( A( I, K+1 ) / D )*CONJG( WKP1 ) + $ A( I, K )*CONJG( WK ) - + $ A( I, K+1 )*CONJG( WKP1 ) 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D - A( J, K+1 ) = WKP1 / D + A( J, K ) = WK + A( J, K+1 ) = WKP1 * (*) Make sure that diagonal element of pivot is real A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO ) * diff --git a/lapack-netlib/SRC/chptrf.c b/lapack-netlib/SRC/chptrf.c index 2a2a8e7916..eb0989c592 100644 --- a/lapack-netlib/SRC/chptrf.c +++ b/lapack-netlib/SRC/chptrf.c @@ -182,14 +182,14 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define r_imag(z) (cimagf(Cf(z))) #define c_abs(z) (cabsf(Cf(z))) #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } #ifdef _MSC_VER #define c_div(c, a, b) {float nenn=crealf(_FCmulcc(Cf(b),conjf(Cf(b)))); _Fcomplex zaehl=_FCmulcc(Cf(a),conjf(Cf(b))); pCf(c)=_FCbuild(crealf(zaehl)/nenn,cimagf(zaehl)/nenn);} -#define z_div(c, a, b) {double nenn=creal(_Cmulcc(Cd(b),conj(Cd(b)))); _Dcomplex zaehl=_Cmulcc(Cd(a),conj(Cd(b))); pCd(c)=_Cbuild(creal(zaehl)/nenn,cimag(zaehl)/nenn);} #else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} #endif #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} @@ -201,14 +201,10 @@ typedef struct Namelist Namelist; #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -234,9 +230,6 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } @@ -256,7 +249,6 @@ typedef struct Namelist Namelist; - /* Table of constant values */ static integer c__1 = 1; @@ -268,7 +260,6 @@ static integer c__1 = 1; /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download CHPTRF + dependencies */ /* > */ @@ -279,7 +270,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -369,9 +359,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complexOTHERcomputational */ +/* > \ingroup hptrf */ /* > \par Further Details: */ /* ===================== */ @@ -424,45 +412,45 @@ f"> */ { /* System generated locals */ integer i__1, i__2, i__3, i__4, i__5, i__6; - real r__1=0., r__2=0., r__3=0., r__4=0.; - complex q__1={0.,0.}, q__2={0.,0.}, q__3={0.,0.}, q__4={0.,0.}, q__5={0.,0.}, q__6={0.,0.}; + real r__1, r__2, r__3, r__4; + complex q__1, q__2, q__3, q__4, q__5, q__6; /* Local variables */ - extern /* Subroutine */ void chpr_(char *, integer *, real *, complex *, - integer *, complex *); - integer imax, jmax; real d__; integer i__, j, k; complex t; - real alpha; - extern logical lsame_(char *, char *); - extern /* Subroutine */ void cswap_(integer *, complex *, integer *, - complex *, integer *); - integer kstep; - logical upper; real r1, d11; complex d12; real d22; complex d21; - extern real slapy2_(real *, real *); integer kc, kk, kp; - real absakk; complex wk; integer kx; - extern integer icamax_(integer *, complex *, integer *); real tt; - extern /* Subroutine */ void csscal_(integer *, real *, complex *, integer - *); - extern void xerbla_(char *, integer *, ftnlen); - real colmax, rowmax; integer knc, kpc, npp; complex wkm1, wkp1; + extern /* Subroutine */ void chpr_(char *, integer *, real *, complex *, + integer *, complex *); + integer imax, jmax; + real alpha; + extern logical lsame_(char *, char *); + extern /* Subroutine */ void cswap_(integer *, complex *, integer *, + complex *, integer *); + integer kstep; + logical upper; + extern real slapy2_(real *, real *); + real absakk; + extern integer icamax_(integer *, complex *, integer *); + extern /* Subroutine */ void csscal_(integer *, real *, complex *, integer + *), xerbla_(char *, integer *, ftnlen); + real colmax; + extern logical sisnan_(real *); + real rowmax; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -530,9 +518,10 @@ f"> */ colmax = 0.f; } - if (f2cmax(absakk,colmax) == 0.f) { + if (f2cmax(absakk,colmax) == 0.f || sisnan_(&absakk)) { -/* Column K is zero: set INFO and continue */ +/* Column K is zero or underflow, or contains a NaN: */ +/* set INFO and continue */ if (*info == 0) { *info = k; @@ -717,27 +706,28 @@ f"> */ i__1 = k - 1 + (k - 1) * k / 2; q__1.r = ap[i__1].r / d__, q__1.i = ap[i__1].i / d__; d12.r = q__1.r, d12.i = q__1.i; - d__ = tt / d__; for (j = k - 2; j >= 1; --j) { i__1 = j + (k - 2) * (k - 1) / 2; - q__3.r = d11 * ap[i__1].r, q__3.i = d11 * ap[i__1].i; - r_cnjg(&q__5, &d12); + q__4.r = d11 * ap[i__1].r, q__4.i = d11 * ap[i__1].i; + r_cnjg(&q__6, &d12); i__2 = j + (k - 1) * k / 2; - q__4.r = q__5.r * ap[i__2].r - q__5.i * ap[i__2].i, - q__4.i = q__5.r * ap[i__2].i + q__5.i * ap[ + q__5.r = q__6.r * ap[i__2].r - q__6.i * ap[i__2].i, + q__5.i = q__6.r * ap[i__2].i + q__6.i * ap[ i__2].r; - q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; - q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i; + q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i; + q__2.r = q__3.r / d__, q__2.i = q__3.i / d__; + q__1.r = tt * q__2.r, q__1.i = tt * q__2.i; wkm1.r = q__1.r, wkm1.i = q__1.i; i__1 = j + (k - 1) * k / 2; - q__3.r = d22 * ap[i__1].r, q__3.i = d22 * ap[i__1].i; + q__4.r = d22 * ap[i__1].r, q__4.i = d22 * ap[i__1].i; i__2 = j + (k - 2) * (k - 1) / 2; - q__4.r = d12.r * ap[i__2].r - d12.i * ap[i__2].i, - q__4.i = d12.r * ap[i__2].i + d12.i * ap[i__2] + q__5.r = d12.r * ap[i__2].r - d12.i * ap[i__2].i, + q__5.i = d12.r * ap[i__2].i + d12.i * ap[i__2] .r; - q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; - q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i; + q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i; + q__2.r = q__3.r / d__, q__2.i = q__3.i / d__; + q__1.r = tt * q__2.r, q__1.i = tt * q__2.i; wk.r = q__1.r, wk.i = q__1.i; for (i__ = j; i__ >= 1; --i__) { i__1 = i__ + (j - 1) * j / 2; @@ -830,9 +820,10 @@ f"> */ colmax = 0.f; } - if (f2cmax(absakk,colmax) == 0.f) { + if (f2cmax(absakk,colmax) == 0.f || sisnan_(&absakk)) { -/* Column K is zero: set INFO and continue */ +/* Column K is zero or underflow, or contains a NaN: */ +/* set INFO and continue */ if (*info == 0) { *info = k; @@ -1026,28 +1017,29 @@ f"> */ i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2; q__1.r = ap[i__1].r / d__, q__1.i = ap[i__1].i / d__; d21.r = q__1.r, d21.i = q__1.i; - d__ = tt / d__; i__1 = *n; for (j = k + 2; j <= i__1; ++j) { i__2 = j + (k - 1) * ((*n << 1) - k) / 2; - q__3.r = d11 * ap[i__2].r, q__3.i = d11 * ap[i__2].i; + q__4.r = d11 * ap[i__2].r, q__4.i = d11 * ap[i__2].i; i__3 = j + k * ((*n << 1) - k - 1) / 2; - q__4.r = d21.r * ap[i__3].r - d21.i * ap[i__3].i, - q__4.i = d21.r * ap[i__3].i + d21.i * ap[i__3] + q__5.r = d21.r * ap[i__3].r - d21.i * ap[i__3].i, + q__5.i = d21.r * ap[i__3].i + d21.i * ap[i__3] .r; - q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; - q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i; + q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i; + q__2.r = q__3.r / d__, q__2.i = q__3.i / d__; + q__1.r = tt * q__2.r, q__1.i = tt * q__2.i; wk.r = q__1.r, wk.i = q__1.i; i__2 = j + k * ((*n << 1) - k - 1) / 2; - q__3.r = d22 * ap[i__2].r, q__3.i = d22 * ap[i__2].i; - r_cnjg(&q__5, &d21); + q__4.r = d22 * ap[i__2].r, q__4.i = d22 * ap[i__2].i; + r_cnjg(&q__6, &d21); i__3 = j + (k - 1) * ((*n << 1) - k) / 2; - q__4.r = q__5.r * ap[i__3].r - q__5.i * ap[i__3].i, - q__4.i = q__5.r * ap[i__3].i + q__5.i * ap[ + q__5.r = q__6.r * ap[i__3].r - q__6.i * ap[i__3].i, + q__5.i = q__6.r * ap[i__3].i + q__6.i * ap[ i__3].r; - q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; - q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i; + q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i; + q__2.r = q__3.r / d__, q__2.i = q__3.i / d__; + q__1.r = tt * q__2.r, q__1.i = tt * q__2.i; wkp1.r = q__1.r, wkp1.i = q__1.i; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { diff --git a/lapack-netlib/SRC/chptrf.f b/lapack-netlib/SRC/chptrf.f index 3d584fd513..bc4048f33e 100644 --- a/lapack-netlib/SRC/chptrf.f +++ b/lapack-netlib/SRC/chptrf.f @@ -389,13 +389,12 @@ SUBROUTINE CHPTRF( UPLO, N, AP, IPIV, INFO ) D11 = REAL( AP( K+( K-1 )*K / 2 ) ) / D TT = ONE / ( D11*D22-ONE ) D12 = AP( K-1+( K-1 )*K / 2 ) / D - D = TT / D * DO 50 J = K - 2, 1, -1 - WKM1 = D*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ CONJG( D12 )*AP( J+( K-1 )*K / 2 ) ) - WK = D*( D22*AP( J+( K-1 )*K / 2 )-D12* - $ AP( J+( K-2 )*( K-1 ) / 2 ) ) + WKM1 = TT*( ( D11*AP( J+( K-2 )*( K-1 ) / 2 )- + $ CONJG( D12 )*AP( J+( K-1 )*K / 2 ) ) / D ) + WK = TT*( ( D22*AP( J+( K-1 )*K / 2 )-D12* + $ AP( J+( K-2 )*( K-1 ) / 2 ) ) / D ) DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*CONJG( WK ) - @@ -603,13 +602,13 @@ SUBROUTINE CHPTRF( UPLO, N, AP, IPIV, INFO ) D22 = REAL( AP( K+( K-1 )*( 2*N-K ) / 2 ) ) / D TT = ONE / ( D11*D22-ONE ) D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 ) / D - D = TT / D * DO 100 J = K + 2, N - WK = D*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-D21* - $ AP( J+K*( 2*N-K-1 ) / 2 ) ) - WKP1 = D*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- - $ CONJG( D21 )*AP( J+( K-1 )*( 2*N-K ) / 2 ) ) + WK = TT*( ( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-D21* + $ AP( J+K*( 2*N-K-1 ) / 2 ) ) / D ) + WKP1 = TT*( ( D22*AP( J+K*( 2*N-K-1 ) / 2 )- + $ CONJG( D21 )*AP( J+( K-1 )*( 2*N-K ) / 2 ) + $ ) / D ) DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / diff --git a/lapack-netlib/SRC/clahef.c b/lapack-netlib/SRC/clahef.c index ef94e33755..42f7b74a3d 100644 --- a/lapack-netlib/SRC/clahef.c +++ b/lapack-netlib/SRC/clahef.c @@ -182,14 +182,14 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define r_imag(z) (cimagf(Cf(z))) #define c_abs(z) (cabsf(Cf(z))) #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } #ifdef _MSC_VER #define c_div(c, a, b) {float nenn=crealf(_FCmulcc(Cf(b),conjf(Cf(b)))); _Fcomplex zaehl=_FCmulcc(Cf(a),conjf(Cf(b))); pCf(c)=_FCbuild(crealf(zaehl)/nenn,cimagf(zaehl)/nenn);} -#define z_div(c, a, b) {double nenn=creal(_Cmulcc(Cd(b),conj(Cd(b)))); _Dcomplex zaehl=_Cmulcc(Cd(a),conj(Cd(b))); pCd(c)=_Cbuild(creal(zaehl)/nenn,cimag(zaehl)/nenn);} #else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} #endif #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} @@ -201,14 +201,10 @@ typedef struct Namelist Namelist; #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -234,9 +230,6 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } @@ -256,7 +249,6 @@ typedef struct Namelist Namelist; - /* Table of constant values */ static complex c_b1 = {1.f,0.f}; @@ -270,7 +262,6 @@ h-Kaufman diagonal pivoting method (blocked algorithm, calling Level 3 BLAS). */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download CLAHEF + dependencies */ /* > */ @@ -281,7 +272,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -424,9 +414,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date November 2013 */ - -/* > \ingroup complexHEcomputational */ +/* > \ingroup lahef */ /* > \par Contributors: */ /* ================== */ @@ -444,16 +432,16 @@ f"> */ integer *info) { /* System generated locals */ - integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; - real r__1=0., r__2=0., r__3=0., r__4=0.; - complex q__1={0.,0.}, q__2={0.,0.}, q__3={0.,0.}, q__4={0.,0.}; + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4; + real r__1, r__2, r__3, r__4; + complex q__1, q__2, q__3, q__4, q__5; /* Local variables */ - integer imax, jmax, j, k; - real t, alpha; - extern /* Subroutine */ void cgemm_(char *, char *, integer *, integer *, - integer *, complex *, complex *, integer *, complex *, integer *, - complex *, complex *, integer *); + integer j, k; + real t, r1; + complex d11, d21, d22; + integer jj, kk, jp, kp, kw, kkw, imax, jmax; + real alpha; extern logical lsame_(char *, char *); extern /* Subroutine */ void cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * @@ -461,23 +449,20 @@ f"> */ complex *, integer *), cswap_(integer *, complex *, integer *, complex *, integer *); integer kstep; - real r1; - complex d11, d21, d22; - integer jb, jj, kk, jp, kp; real absakk; extern /* Subroutine */ void clacgv_(integer *, complex *, integer *); - integer kw; extern integer icamax_(integer *, complex *, integer *); extern /* Subroutine */ void csscal_(integer *, real *, complex *, integer *); real colmax, rowmax; - integer kkw; + extern /* Subroutine */ void cgemmtr_(char *, char *, char *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *); -/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* November 2013 */ /* ===================================================================== */ @@ -485,11 +470,11 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; w_dim1 = *ldw; - w_offset = 1 + w_dim1 * 1; + w_offset = 1 + w_dim1; w -= w_offset; /* Function Body */ @@ -516,7 +501,7 @@ f"> */ /* Exit from loop */ - if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { goto L30; } @@ -532,7 +517,7 @@ f"> */ w[i__1].r = r__1, w[i__1].i = 0.f; if (k < *n) { i__1 = *n - k; - q__1.r = -1.f, q__1.i = 0.f; + q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * a_dim1 + 1], lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * w_dim1 + 1], &c__1); @@ -570,10 +555,7 @@ f"> */ *info = k; } kp = k; - i__1 = k + k * a_dim1; - i__2 = k + k * a_dim1; - r__1 = a[i__2].r; - a[i__1].r = r__1, a[i__1].i = 0.f; + ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); } else { /* ============================================================ */ @@ -607,7 +589,7 @@ f"> */ clacgv_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1); if (k < *n) { i__1 = *n - k; - q__1.r = -1.f, q__1.i = 0.f; + q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1); @@ -808,17 +790,17 @@ f"> */ /* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = */ /* ( ( -1 ) ( D22 ) ) */ -/* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = */ +/* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ), */ /* ( ( -1 ) ( D22 ) ) */ -/* = ( conj(D21)*( D11 ) D21*( -1 ) ) */ -/* ( ( -1 ) ( D22 ) ), */ - /* where D11 = d22/d21, */ /* D22 = d11/conj(d21), */ -/* D21 = T/d21, */ /* T = 1/(D22*D11-1). */ +/* T/d21 is not formed, since it overflows when d21 is */ +/* subnormal: each entry of the product is divided by */ +/* d21 or conj(d21) and then scaled by T. */ + /* (NOTE: No need to check for division by ZERO, */ /* since that was ensured earlier in pivot search: */ /* (a) d21 != 0, since in 2x2 pivot case(4) */ @@ -836,9 +818,6 @@ f"> */ q__1.r = d11.r * d22.r - d11.i * d22.i, q__1.i = d11.r * d22.i + d11.i * d22.r; t = 1.f / (q__1.r - 1.f); - q__2.r = t, q__2.i = 0.f; - c_div(&q__1, &q__2, &d21); - d21.r = q__1.r, d21.i = q__1.i; /* Update elements in columns A(k-1) and A(k) as */ /* dot products of rows of ( W(kw-1) W(kw) ) and columns */ @@ -848,17 +827,16 @@ f"> */ for (j = 1; j <= i__1; ++j) { i__2 = j + (k - 1) * a_dim1; i__3 = j + (kw - 1) * w_dim1; - q__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i, - q__3.i = d11.r * w[i__3].i + d11.i * w[i__3] + q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + q__4.i = d11.r * w[i__3].i + d11.i * w[i__3] .r; i__4 = j + kw * w_dim1; - q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4] + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] .i; - q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = - d21.r * q__2.i + d21.i * q__2.r; + c_div(&q__2, &q__3, &d21); + q__1.r = t * q__2.r, q__1.i = t * q__2.i; a[i__2].r = q__1.r, a[i__2].i = q__1.i; i__2 = j + k * a_dim1; - r_cnjg(&q__2, &d21); i__3 = j + kw * w_dim1; q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, q__4.i = d22.r * w[i__3].i + d22.i * w[i__3] @@ -866,8 +844,9 @@ f"> */ i__4 = j + (kw - 1) * w_dim1; q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] .i; - q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = - q__2.r * q__3.i + q__2.i * q__3.r; + r_cnjg(&q__5, &d21); + c_div(&q__2, &q__3, &q__5); + q__1.r = t * q__2.r, q__1.i = t * q__2.i; a[i__2].r = q__1.r, a[i__2].i = q__1.i; /* L20: */ } @@ -916,47 +895,13 @@ f"> */ /* A11 := A11 - U12*D*U12**H = A11 - U12*W**H */ -/* computing blocks of NB columns at a time (note that conjg(W) is */ -/* actually stored) */ - - i__1 = -(*nb); - for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += - i__1) { -/* Computing MIN */ - i__2 = *nb, i__3 = k - j + 1; - jb = f2cmin(i__2,i__3); - -/* Update the upper triangle of the diagonal block */ - - i__2 = j + jb - 1; - for (jj = j; jj <= i__2; ++jj) { - i__3 = jj + jj * a_dim1; - i__4 = jj + jj * a_dim1; - r__1 = a[i__4].r; - a[i__3].r = r__1, a[i__3].i = 0.f; - i__3 = jj - j + 1; - i__4 = *n - k; - q__1.r = -1.f, q__1.i = 0.f; - cgemv_("No transpose", &i__3, &i__4, &q__1, &a[j + (k + 1) * - a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1, - &a[j + jj * a_dim1], &c__1); - i__3 = jj + jj * a_dim1; - i__4 = jj + jj * a_dim1; - r__1 = a[i__4].r; - a[i__3].r = r__1, a[i__3].i = 0.f; -/* L40: */ - } - -/* Update the rectangular superdiagonal block */ +/* (note that conjg(W) is actually stored) */ - i__2 = j - 1; - i__3 = *n - k; - q__1.r = -1.f, q__1.i = 0.f; - cgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &q__1, &a[( - k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw, - &c_b1, &a[j * a_dim1 + 1], lda); -/* L50: */ - } + i__1 = *n - k; + q__1.r = -1.f, q__1.i = -0.f; + cgemmtr_("Upper", "No transpose", "Transpose", &k, &i__1, &q__1, &a[( + k + 1) * a_dim1 + 1], lda, &w[(kw + 1) * w_dim1 + 1], ldw, & + c_b1, &a[a_dim1 + 1], lda); /* Put U12 in standard form by partially undoing the interchanges */ /* in of rows in columns k+1:n looping backwards from k+1 to n */ @@ -1003,7 +948,7 @@ f"> */ /* Exit from loop */ - if ((k >= *nb && *nb < *n) || k > *n) { + if (k >= *nb && *nb < *n || k > *n) { goto L90; } @@ -1022,7 +967,7 @@ f"> */ } i__1 = *n - k + 1; i__2 = k - 1; - q__1.r = -1.f, q__1.i = 0.f; + q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], lda, &w[k + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1); i__1 = k + k * w_dim1; @@ -1058,10 +1003,9 @@ f"> */ *info = k; } kp = k; - i__1 = k + k * a_dim1; - i__2 = k + k * a_dim1; - r__1 = a[i__2].r; - a[i__1].r = r__1, a[i__1].i = 0.f; + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); } else { /* ============================================================ */ @@ -1097,7 +1041,7 @@ f"> */ } i__1 = *n - k + 1; i__2 = k - 1; - q__1.r = -1.f, q__1.i = 0.f; + q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + 1) * w_dim1], &c__1); @@ -1293,17 +1237,17 @@ f"> */ /* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = */ /* ( ( -1 ) ( D22 ) ) */ -/* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = */ +/* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ), */ /* ( ( -1 ) ( D22 ) ) */ -/* = ( conj(D21)*( D11 ) D21*( -1 ) ) */ -/* ( ( -1 ) ( D22 ) ) */ - /* where D11 = d22/d21, */ /* D22 = d11/conj(d21), */ -/* D21 = T/d21, */ /* T = 1/(D22*D11-1). */ +/* T/d21 is not formed, since it overflows when d21 is */ +/* subnormal: each entry of the product is divided by */ +/* d21 or conj(d21) and then scaled by T. */ + /* (NOTE: No need to check for division by ZERO, */ /* since that was ensured earlier in pivot search: */ /* (a) d21 != 0, since in 2x2 pivot case(4) */ @@ -1321,9 +1265,6 @@ f"> */ q__1.r = d11.r * d22.r - d11.i * d22.i, q__1.i = d11.r * d22.i + d11.i * d22.r; t = 1.f / (q__1.r - 1.f); - q__2.r = t, q__2.i = 0.f; - c_div(&q__1, &q__2, &d21); - d21.r = q__1.r, d21.i = q__1.i; /* Update elements in columns A(k) and A(k+1) as */ /* dot products of rows of ( W(k) W(k+1) ) and columns */ @@ -1332,7 +1273,6 @@ f"> */ i__1 = *n; for (j = k + 2; j <= i__1; ++j) { i__2 = j + k * a_dim1; - r_cnjg(&q__2, &d21); i__3 = j + k * w_dim1; q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, q__4.i = d11.r * w[i__3].i + d11.i * w[i__3] @@ -1340,19 +1280,20 @@ f"> */ i__4 = j + (k + 1) * w_dim1; q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] .i; - q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = - q__2.r * q__3.i + q__2.i * q__3.r; + r_cnjg(&q__5, &d21); + c_div(&q__2, &q__3, &q__5); + q__1.r = t * q__2.r, q__1.i = t * q__2.i; a[i__2].r = q__1.r, a[i__2].i = q__1.i; i__2 = j + (k + 1) * a_dim1; i__3 = j + (k + 1) * w_dim1; - q__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i, - q__3.i = d22.r * w[i__3].i + d22.i * w[i__3] + q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + q__4.i = d22.r * w[i__3].i + d22.i * w[i__3] .r; i__4 = j + k * w_dim1; - q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4] + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] .i; - q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = - d21.r * q__2.i + d21.i * q__2.r; + c_div(&q__2, &q__3, &d21); + q__1.r = t * q__2.r, q__1.i = t * q__2.i; a[i__2].r = q__1.r, a[i__2].i = q__1.i; /* L80: */ } @@ -1401,49 +1342,14 @@ f"> */ /* A22 := A22 - L21*D*L21**H = A22 - L21*W**H */ -/* computing blocks of NB columns at a time (note that conjg(W) is */ -/* actually stored) */ - - i__1 = *n; - i__2 = *nb; - for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { -/* Computing MIN */ - i__3 = *nb, i__4 = *n - j + 1; - jb = f2cmin(i__3,i__4); - -/* Update the lower triangle of the diagonal block */ - - i__3 = j + jb - 1; - for (jj = j; jj <= i__3; ++jj) { - i__4 = jj + jj * a_dim1; - i__5 = jj + jj * a_dim1; - r__1 = a[i__5].r; - a[i__4].r = r__1, a[i__4].i = 0.f; - i__4 = j + jb - jj; - i__5 = k - 1; - q__1.r = -1.f, q__1.i = 0.f; - cgemv_("No transpose", &i__4, &i__5, &q__1, &a[jj + a_dim1], - lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1] - , &c__1); - i__4 = jj + jj * a_dim1; - i__5 = jj + jj * a_dim1; - r__1 = a[i__5].r; - a[i__4].r = r__1, a[i__4].i = 0.f; -/* L100: */ - } - -/* Update the rectangular subdiagonal block */ +/* (note that conjg(W) is actually stored) */ - if (j + jb <= *n) { - i__3 = *n - j - jb + 1; - i__4 = k - 1; - q__1.r = -1.f, q__1.i = 0.f; - cgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &q__1, - &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1, - &a[j + jb + j * a_dim1], lda); - } -/* L110: */ - } + i__1 = *n - k + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = -0.f; + cgemmtr_("Lower", "No transpose", "Transpose", &i__1, &i__2, &q__1, & + a[k + a_dim1], lda, &w[k + w_dim1], ldw, &c_b1, &a[k + k * + a_dim1], lda); /* Put L21 in standard form by partially undoing the interchanges */ /* of rows in columns 1:k-1 looping backwards from k-1 to 1 */ diff --git a/lapack-netlib/SRC/clahef.f b/lapack-netlib/SRC/clahef.f index 60ec116d6b..49474402df 100644 --- a/lapack-netlib/SRC/clahef.f +++ b/lapack-netlib/SRC/clahef.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CLAHEF + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -160,7 +158,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexHEcomputational +*> \ingroup lahef * *> \par Contributors: * ================== @@ -173,7 +171,9 @@ *> \endverbatim * * ===================================================================== - SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) + SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, + $ INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -199,7 +199,7 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) * .. * .. Local Scalars .. - INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP, + INTEGER IMAX, J, JJ, JMAX, JP, K, KK, KKW, KP, $ KSTEP, KW REAL ABSAKK, ALPHA, COLMAX, R1, ROWMAX, T COMPLEX D11, D21, D22, Z @@ -210,7 +210,8 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) EXTERNAL LSAME, ICAMAX * .. * .. External Subroutines .. - EXTERNAL CCOPY, CGEMM, CGEMV, CLACGV, CSSCAL, CSWAP + EXTERNAL CCOPY, CGEMMTR, CGEMV, CLACGV, CSSCAL, + $ CSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CONJG, MAX, MIN, REAL, SQRT @@ -256,7 +257,8 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) CALL CCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 ) W( K, KW ) = REAL( A( K, K ) ) IF( K.LT.N ) THEN - CALL CGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA, + CALL CGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), + $ LDA, $ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 ) W( K, KW ) = REAL( W( K, KW ) ) END IF @@ -284,7 +286,7 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) IF( INFO.EQ.0 ) $ INFO = K KP = K - A( K, K ) = REAL( A( K, K ) ) + CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) ELSE * * ============================================================ @@ -479,17 +481,17 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = * ( ( -1 ) ( D22 ) ) * -* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ), * ( ( -1 ) ( D22 ) ) * -* = ( conj(D21)*( D11 ) D21*( -1 ) ) -* ( ( -1 ) ( D22 ) ), -* * where D11 = d22/d21, * D22 = d11/conj(d21), -* D21 = T/d21, * T = 1/(D22*D11-1). * +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 or conj(d21) and then scaled by T. +* * (NOTE: No need to check for division by ZERO, * since that was ensured earlier in pivot search: * (a) d21 != 0, since in 2x2 pivot case(4) @@ -501,16 +503,16 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) D11 = W( K, KW ) / CONJG( D21 ) D22 = W( K-1, KW-1 ) / D21 T = ONE / ( REAL( D11*D22 )-ONE ) - D21 = T / D21 * * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) * DO 20 J = 1, K - 2 - A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) - A( J, K ) = CONJG( D21 )* - $ ( D22*W( J, KW )-W( J, KW-1 ) ) + A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ CONJG( D21 ) ) 20 CONTINUE END IF * @@ -549,28 +551,11 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * A11 := A11 - U12*D*U12**H = A11 - U12*W**H * -* computing blocks of NB columns at a time (note that conjg(W) is -* actually stored) -* - DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB - JB = MIN( NB, K-J+1 ) -* -* Update the upper triangle of the diagonal block +* (note that conjg(W) is actually stored) * - DO 40 JJ = J, J + JB - 1 - A( JJ, JJ ) = REAL( A( JJ, JJ ) ) - CALL CGEMV( 'No transpose', JJ-J+1, N-K, -CONE, - $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE, - $ A( J, JJ ), 1 ) - A( JJ, JJ ) = REAL( A( JJ, JJ ) ) - 40 CONTINUE -* -* Update the rectangular superdiagonal block -* - CALL CGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, - $ -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, - $ CONE, A( 1, J ), LDA ) - 50 CONTINUE + CALL CGEMMTR( 'Upper', 'No transpose', 'Transpose', K, N-K, + $ -CONE, A( 1, K+1 ), LDA, W( 1, KW+1 ), LDW, + $ CONE, A( 1, 1 ), LDA ) * * Put U12 in standard form by partially undoing the interchanges * in of rows in columns k+1:n looping backwards from k+1 to n @@ -624,7 +609,8 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) W( K, K ) = REAL( A( K, K ) ) IF( K.LT.N ) $ CALL CCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 ) - CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), LDA, + CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), + $ LDA, $ W( K, 1 ), LDW, CONE, W( K, K ), 1 ) W( K, K ) = REAL( W( K, K ) ) * @@ -651,7 +637,7 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) IF( INFO.EQ.0 ) $ INFO = K KP = K - A( K, K ) = REAL( A( K, K ) ) + CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) ELSE * * ============================================================ @@ -671,13 +657,15 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * Copy column IMAX to column K+1 of W and update it * - CALL CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 ) + CALL CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), + $ 1 ) CALL CLACGV( IMAX-K, W( K, K+1 ), 1 ) W( IMAX, K+1 ) = REAL( A( IMAX, IMAX ) ) IF( IMAX.LT.N ) $ CALL CCOPY( N-IMAX, A( IMAX+1, IMAX ), 1, $ W( IMAX+1, K+1 ), 1 ) - CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), + CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, + $ 1 ), $ LDA, W( IMAX, 1 ), LDW, CONE, W( K, K+1 ), $ 1 ) W( IMAX, K+1 ) = REAL( W( IMAX, K+1 ) ) @@ -751,7 +739,8 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) $ LDA ) CALL CLACGV( KP-KK-1, A( KP, KK+1 ), LDA ) IF( KP.LT.N ) - $ CALL CCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL CCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) * * Interchange rows KK and KP in first K-1 columns of A * (columns K (or K and K+1 for 2-by-2 pivot) of A will be @@ -839,17 +828,17 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = * ( ( -1 ) ( D22 ) ) * -* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ), * ( ( -1 ) ( D22 ) ) * -* = ( conj(D21)*( D11 ) D21*( -1 ) ) -* ( ( -1 ) ( D22 ) ) -* * where D11 = d22/d21, * D22 = d11/conj(d21), -* D21 = T/d21, * T = 1/(D22*D11-1). * +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 or conj(d21) and then scaled by T. +* * (NOTE: No need to check for division by ZERO, * since that was ensured earlier in pivot search: * (a) d21 != 0, since in 2x2 pivot case(4) @@ -861,16 +850,16 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / CONJG( D21 ) T = ONE / ( REAL( D11*D22 )-ONE ) - D21 = T / D21 * * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) * DO 80 J = K + 2, N - A( J, K ) = CONJG( D21 )* - $ ( D11*W( J, K )-W( J, K+1 ) ) - A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ CONJG( D21 ) ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * @@ -909,29 +898,11 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * A22 := A22 - L21*D*L21**H = A22 - L21*W**H * -* computing blocks of NB columns at a time (note that conjg(W) is -* actually stored) -* - DO 110 J = K, N, NB - JB = MIN( NB, N-J+1 ) -* -* Update the lower triangle of the diagonal block -* - DO 100 JJ = J, J + JB - 1 - A( JJ, JJ ) = REAL( A( JJ, JJ ) ) - CALL CGEMV( 'No transpose', J+JB-JJ, K-1, -CONE, - $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE, - $ A( JJ, JJ ), 1 ) - A( JJ, JJ ) = REAL( A( JJ, JJ ) ) - 100 CONTINUE -* -* Update the rectangular subdiagonal block +* (note that conjg(W) is actually stored) * - IF( J+JB.LE.N ) - $ CALL CGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, - $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ), - $ LDW, CONE, A( J+JB, J ), LDA ) - 110 CONTINUE + CALL CGEMMTR( 'Lower', 'No transpose', 'Transpose', N-K+1, + $ K-1, -CONE, A( K, 1 ), LDA, W( K, 1 ), LDW, + $ CONE, A( K, K ), LDA ) * * Put L21 in standard form by partially undoing the interchanges * of rows in columns 1:k-1 looping backwards from k-1 to 1 diff --git a/lapack-netlib/SRC/clasyf.c b/lapack-netlib/SRC/clasyf.c index 39cfa1a195..cbdd8038e0 100644 --- a/lapack-netlib/SRC/clasyf.c +++ b/lapack-netlib/SRC/clasyf.c @@ -182,14 +182,14 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define r_imag(z) (cimagf(Cf(z))) #define c_abs(z) (cabsf(Cf(z))) #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } #ifdef _MSC_VER #define c_div(c, a, b) {float nenn=crealf(_FCmulcc(Cf(b),conjf(Cf(b)))); _Fcomplex zaehl=_FCmulcc(Cf(a),conjf(Cf(b))); pCf(c)=_FCbuild(crealf(zaehl)/nenn,cimagf(zaehl)/nenn);} -#define z_div(c, a, b) {double nenn=creal(_Cmulcc(Cd(b),conj(Cd(b)))); _Dcomplex zaehl=_Cmulcc(Cd(a),conj(Cd(b))); pCd(c)=_Cbuild(creal(zaehl)/nenn,cimag(zaehl)/nenn);} #else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} #endif #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} @@ -201,14 +201,10 @@ typedef struct Namelist Namelist; #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -234,9 +230,6 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } @@ -256,7 +249,6 @@ typedef struct Namelist Namelist; - /* Table of constant values */ static complex c_b1 = {1.f,0.f}; @@ -270,7 +262,6 @@ iagonal pivoting method. */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download CLASYF + dependencies */ /* > */ @@ -281,7 +272,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -424,9 +414,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date November 2013 */ - -/* > \ingroup complexSYcomputational */ +/* > \ingroup lahef */ /* > \par Contributors: */ /* ================== */ @@ -444,18 +432,17 @@ f"> */ integer *info) { /* System generated locals */ - integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; - real r__1=0., r__2=0., r__3=0., r__4=0.; - complex q__1={0.,0.}, q__2={0.,0.}, q__3={0.,0.}; + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4; + real r__1, r__2, r__3, r__4; + complex q__1, q__2, q__3, q__4; /* Local variables */ - integer imax, jmax, j, k; - complex t; + integer j, k; + complex t, r1, d11, d21, d22; + integer jj, kk, jp, kp, kw, kkw, imax, jmax; real alpha; extern /* Subroutine */ void cscal_(integer *, complex *, complex *, - integer *), cgemm_(char *, char *, integer *, integer *, integer * - , complex *, complex *, integer *, complex *, integer *, complex * - , complex *, integer *); + integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ void cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * @@ -463,19 +450,17 @@ f"> */ complex *, integer *), cswap_(integer *, complex *, integer *, complex *, integer *); integer kstep; - complex r1, d11, d21, d22; - integer jb, jj, kk, jp, kp; real absakk; - integer kw; extern integer icamax_(integer *, complex *, integer *); real colmax, rowmax; - integer kkw; + extern /* Subroutine */ void cgemmtr_(char *, char *, char *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *); -/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* November 2013 */ /* ===================================================================== */ @@ -483,11 +468,11 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; w_dim1 = *ldw; - w_offset = 1 + w_dim1 * 1; + w_offset = 1 + w_dim1; w -= w_offset; /* Function Body */ @@ -513,7 +498,7 @@ f"> */ /* Exit from loop */ - if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { goto L30; } @@ -522,7 +507,7 @@ f"> */ ccopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); if (k < *n) { i__1 = *n - k; - q__1.r = -1.f, q__1.i = 0.f; + q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * a_dim1 + 1], lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * w_dim1 + 1], &c__1); @@ -559,6 +544,7 @@ f"> */ *info = k; } kp = k; + ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); } else { if (absakk >= alpha * colmax) { @@ -576,7 +562,7 @@ f"> */ 1 + (kw - 1) * w_dim1], &c__1); if (k < *n) { i__1 = *n - k; - q__1.r = -1.f, q__1.i = 0.f; + q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1); @@ -743,8 +729,9 @@ f"> */ /* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */ /* ( ( -1 ) ( D22 ) ) */ -/* = D21 * ( ( D11 ) ( -1 ) ) */ -/* ( ( -1 ) ( D22 ) ) */ +/* T/d21 is not formed, since it overflows when d21 is */ +/* subnormal: each entry of the product is divided by */ +/* d21 and then scaled by T. */ i__1 = k - 1 + kw * w_dim1; d21.r = w[i__1].r, d21.i = w[i__1].i; @@ -754,7 +741,7 @@ f"> */ d22.r = q__1.r, d22.i = q__1.i; q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * d22.i + d11.i * d22.r; - q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f; c_div(&q__1, &c_b1, &q__2); t.r = q__1.r, t.i = q__1.i; @@ -762,31 +749,31 @@ f"> */ /* dot products of rows of ( W(kw-1) W(kw) ) and columns */ /* of D**(-1) */ - c_div(&q__1, &t, &d21); - d21.r = q__1.r, d21.i = q__1.i; i__1 = k - 2; for (j = 1; j <= i__1; ++j) { i__2 = j + (k - 1) * a_dim1; i__3 = j + (kw - 1) * w_dim1; - q__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i, - q__3.i = d11.r * w[i__3].i + d11.i * w[i__3] + q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + q__4.i = d11.r * w[i__3].i + d11.i * w[i__3] .r; i__4 = j + kw * w_dim1; - q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4] + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] .i; - q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = - d21.r * q__2.i + d21.i * q__2.r; + c_div(&q__2, &q__3, &d21); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; a[i__2].r = q__1.r, a[i__2].i = q__1.i; i__2 = j + k * a_dim1; i__3 = j + kw * w_dim1; - q__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i, - q__3.i = d22.r * w[i__3].i + d22.i * w[i__3] + q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + q__4.i = d22.r * w[i__3].i + d22.i * w[i__3] .r; i__4 = j + (kw - 1) * w_dim1; - q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4] + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] .i; - q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = - d21.r * q__2.i + d21.i * q__2.r; + c_div(&q__2, &q__3, &d21); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; a[i__2].r = q__1.r, a[i__2].i = q__1.i; /* L20: */ } @@ -828,38 +815,11 @@ f"> */ /* A11 := A11 - U12*D*U12**T = A11 - U12*W**T */ -/* computing blocks of NB columns at a time */ - - i__1 = -(*nb); - for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += - i__1) { -/* Computing MIN */ - i__2 = *nb, i__3 = k - j + 1; - jb = f2cmin(i__2,i__3); - -/* Update the upper triangle of the diagonal block */ - - i__2 = j + jb - 1; - for (jj = j; jj <= i__2; ++jj) { - i__3 = jj - j + 1; - i__4 = *n - k; - q__1.r = -1.f, q__1.i = 0.f; - cgemv_("No transpose", &i__3, &i__4, &q__1, &a[j + (k + 1) * - a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1, - &a[j + jj * a_dim1], &c__1); -/* L40: */ - } - -/* Update the rectangular superdiagonal block */ - - i__2 = j - 1; - i__3 = *n - k; - q__1.r = -1.f, q__1.i = 0.f; - cgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &q__1, &a[( - k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw, - &c_b1, &a[j * a_dim1 + 1], lda); -/* L50: */ - } + i__1 = *n - k; + q__1.r = -1.f, q__1.i = -0.f; + cgemmtr_("Upper", "No transpose", "Transpose", &k, &i__1, &q__1, &a[( + k + 1) * a_dim1 + 1], lda, &w[(kw + 1) * w_dim1 + 1], ldw, & + c_b1, &a[a_dim1 + 1], lda); /* Put U12 in standard form by partially undoing the interchanges */ /* in columns k+1:n looping backwards from k+1 to n */ @@ -906,7 +866,7 @@ f"> */ /* Exit from loop */ - if ((k >= *nb && *nb < *n) || k > *n) { + if (k >= *nb && *nb < *n || k > *n) { goto L90; } @@ -916,7 +876,7 @@ f"> */ ccopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); i__1 = *n - k + 1; i__2 = k - 1; - q__1.r = -1.f, q__1.i = 0.f; + q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], lda, &w[k + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1); @@ -951,6 +911,9 @@ f"> */ *info = k; } kp = k; + i__1 = *n - k + 1; + ccopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); } else { if (absakk >= alpha * colmax) { @@ -969,7 +932,7 @@ f"> */ 1) * w_dim1], &c__1); i__1 = *n - k + 1; i__2 = k - 1; - q__1.r = -1.f, q__1.i = 0.f; + q__1.r = -1.f, q__1.i = -0.f; cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + 1) * w_dim1], &c__1); @@ -1133,8 +1096,9 @@ f"> */ /* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */ /* ( ( -1 ) ( D22 ) ) */ -/* = D21 * ( ( D11 ) ( -1 ) ) */ -/* ( ( -1 ) ( D22 ) ) */ +/* T/d21 is not formed, since it overflows when d21 is */ +/* subnormal: each entry of the product is divided by */ +/* d21 and then scaled by T. */ i__1 = k + 1 + k * w_dim1; d21.r = w[i__1].r, d21.i = w[i__1].i; @@ -1144,11 +1108,9 @@ f"> */ d22.r = q__1.r, d22.i = q__1.i; q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * d22.i + d11.i * d22.r; - q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f; c_div(&q__1, &c_b1, &q__2); t.r = q__1.r, t.i = q__1.i; - c_div(&q__1, &t, &d21); - d21.r = q__1.r, d21.i = q__1.i; /* Update elements in columns A(k) and A(k+1) as */ /* dot products of rows of ( W(k) W(k+1) ) and columns */ @@ -1158,25 +1120,27 @@ f"> */ for (j = k + 2; j <= i__1; ++j) { i__2 = j + k * a_dim1; i__3 = j + k * w_dim1; - q__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i, - q__3.i = d11.r * w[i__3].i + d11.i * w[i__3] + q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + q__4.i = d11.r * w[i__3].i + d11.i * w[i__3] .r; i__4 = j + (k + 1) * w_dim1; - q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4] + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] .i; - q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = - d21.r * q__2.i + d21.i * q__2.r; + c_div(&q__2, &q__3, &d21); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; a[i__2].r = q__1.r, a[i__2].i = q__1.i; i__2 = j + (k + 1) * a_dim1; i__3 = j + (k + 1) * w_dim1; - q__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i, - q__3.i = d22.r * w[i__3].i + d22.i * w[i__3] + q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + q__4.i = d22.r * w[i__3].i + d22.i * w[i__3] .r; i__4 = j + k * w_dim1; - q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4] + q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4] .i; - q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = - d21.r * q__2.i + d21.i * q__2.r; + c_div(&q__2, &q__3, &d21); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; a[i__2].r = q__1.r, a[i__2].i = q__1.i; /* L80: */ } @@ -1218,40 +1182,12 @@ f"> */ /* A22 := A22 - L21*D*L21**T = A22 - L21*W**T */ -/* computing blocks of NB columns at a time */ - - i__1 = *n; - i__2 = *nb; - for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { -/* Computing MIN */ - i__3 = *nb, i__4 = *n - j + 1; - jb = f2cmin(i__3,i__4); - -/* Update the lower triangle of the diagonal block */ - - i__3 = j + jb - 1; - for (jj = j; jj <= i__3; ++jj) { - i__4 = j + jb - jj; - i__5 = k - 1; - q__1.r = -1.f, q__1.i = 0.f; - cgemv_("No transpose", &i__4, &i__5, &q__1, &a[jj + a_dim1], - lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1] - , &c__1); -/* L100: */ - } - -/* Update the rectangular subdiagonal block */ - - if (j + jb <= *n) { - i__3 = *n - j - jb + 1; - i__4 = k - 1; - q__1.r = -1.f, q__1.i = 0.f; - cgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &q__1, - &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1, - &a[j + jb + j * a_dim1], lda); - } -/* L110: */ - } + i__1 = *n - k + 1; + i__2 = k - 1; + q__1.r = -1.f, q__1.i = -0.f; + cgemmtr_("Lower", "No transpose", "Transpose", &i__1, &i__2, &q__1, & + a[k + a_dim1], lda, &w[k + w_dim1], ldw, &c_b1, &a[k + k * + a_dim1], lda); /* Put L21 in standard form by partially undoing the interchanges */ /* of rows in columns 1:k-1 looping backwards from k-1 to 1 */ diff --git a/lapack-netlib/SRC/clasyf.f b/lapack-netlib/SRC/clasyf.f index e6666cfed6..5f1eb04f61 100644 --- a/lapack-netlib/SRC/clasyf.f +++ b/lapack-netlib/SRC/clasyf.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CLASYF + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -160,7 +158,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexSYcomputational +*> \ingroup lahef * *> \par Contributors: * ================== @@ -173,7 +171,9 @@ *> \endverbatim * * ===================================================================== - SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) + SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, + $ INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -199,7 +199,7 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. - INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP, + INTEGER IMAX, J, JJ, JMAX, JP, K, KK, KKW, KP, $ KSTEP, KW REAL ABSAKK, ALPHA, COLMAX, ROWMAX COMPLEX D11, D21, D22, R1, T, Z @@ -210,7 +210,7 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) EXTERNAL LSAME, ICAMAX * .. * .. External Subroutines .. - EXTERNAL CCOPY, CGEMM, CGEMV, CSCAL, CSWAP + EXTERNAL CCOPY, CGEMMTR, CGEMV, CSCAL, CSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, MAX, MIN, REAL, SQRT @@ -252,7 +252,8 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * CALL CCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) IF( K.LT.N ) - $ CALL CGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA, + $ CALL CGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), + $ LDA, $ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 ) * KSTEP = 1 @@ -280,6 +281,7 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * @@ -431,8 +433,9 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* = D21 * ( ( D11 ) ( -1 ) ) -* ( ( -1 ) ( D22 ) ) +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 @@ -443,10 +446,11 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) * - D21 = T / D21 DO 20 J = 1, K - 2 - A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) - A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D21 ) 20 CONTINUE END IF * @@ -480,25 +484,9 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * A11 := A11 - U12*D*U12**T = A11 - U12*W**T * -* computing blocks of NB columns at a time -* - DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB - JB = MIN( NB, K-J+1 ) -* -* Update the upper triangle of the diagonal block -* - DO 40 JJ = J, J + JB - 1 - CALL CGEMV( 'No transpose', JJ-J+1, N-K, -CONE, - $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE, - $ A( J, JJ ), 1 ) - 40 CONTINUE -* -* Update the rectangular superdiagonal block -* - CALL CGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, - $ -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, - $ CONE, A( 1, J ), LDA ) - 50 CONTINUE + CALL CGEMMTR( 'Upper', 'No transpose', 'Transpose', K, N-K, + $ -CONE, A( 1, K+1 ), LDA, W( 1, KW+1 ), LDW, + $ CONE, A( 1, 1 ), LDA ) * * Put U12 in standard form by partially undoing the interchanges * in columns k+1:n looping backwards from k+1 to n @@ -548,7 +536,8 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * Copy column K of A to column K of W and update it * CALL CCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) - CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), LDA, + CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), + $ LDA, $ W( K, 1 ), LDW, CONE, W( K, K ), 1 ) * KSTEP = 1 @@ -576,6 +565,7 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * @@ -586,10 +576,13 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * Copy column IMAX to column K+1 of W and update it * - CALL CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 ) - CALL CCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ), + CALL CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), + $ 1 ) + CALL CCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, + $ K+1 ), $ 1 ) - CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), + CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, + $ 1 ), $ LDA, W( IMAX, 1 ), LDW, CONE, W( K, K+1 ), $ 1 ) * @@ -648,7 +641,8 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) CALL CCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), $ LDA ) IF( KP.LT.N ) - $ CALL CCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL CCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) * * Interchange rows KK and KP in first K-1 columns of A * (columns K (or K and K+1 for 2-by-2 pivot) of A will be @@ -722,22 +716,24 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* = D21 * ( ( D11 ) ( -1 ) ) -* ( ( -1 ) ( D22 ) ) +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = CONE / ( D11*D22-CONE ) - D21 = T / D21 * * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) * DO 80 J = K + 2, N - A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) - A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * @@ -771,26 +767,9 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * A22 := A22 - L21*D*L21**T = A22 - L21*W**T * -* computing blocks of NB columns at a time -* - DO 110 J = K, N, NB - JB = MIN( NB, N-J+1 ) -* -* Update the lower triangle of the diagonal block -* - DO 100 JJ = J, J + JB - 1 - CALL CGEMV( 'No transpose', J+JB-JJ, K-1, -CONE, - $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE, - $ A( JJ, JJ ), 1 ) - 100 CONTINUE -* -* Update the rectangular subdiagonal block -* - IF( J+JB.LE.N ) - $ CALL CGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, - $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ), - $ LDW, CONE, A( J+JB, J ), LDA ) - 110 CONTINUE + CALL CGEMMTR( 'Lower', 'No transpose', 'Transpose', N-K+1, + $ K-1, -CONE, A( K, 1 ), LDA, W( K, 1 ), LDW, + $ CONE, A( K, K ), LDA ) * * Put L21 in standard form by partially undoing the interchanges * of rows in columns 1:k-1 looping backwards from k-1 to 1 diff --git a/lapack-netlib/SRC/csptrf.c b/lapack-netlib/SRC/csptrf.c index f5be17efe0..feb27cff1a 100644 --- a/lapack-netlib/SRC/csptrf.c +++ b/lapack-netlib/SRC/csptrf.c @@ -182,14 +182,14 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define r_imag(z) (cimagf(Cf(z))) #define c_abs(z) (cabsf(Cf(z))) #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } #ifdef _MSC_VER #define c_div(c, a, b) {float nenn=crealf(_FCmulcc(Cf(b),conjf(Cf(b)))); _Fcomplex zaehl=_FCmulcc(Cf(a),conjf(Cf(b))); pCf(c)=_FCbuild(crealf(zaehl)/nenn,cimagf(zaehl)/nenn);} -#define z_div(c, a, b) {double nenn=creal(_Cmulcc(Cd(b),conj(Cd(b)))); _Dcomplex zaehl=_Cmulcc(Cd(a),conj(Cd(b))); pCd(c)=_Cbuild(creal(zaehl)/nenn,cimag(zaehl)/nenn);} #else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} #endif #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} @@ -201,14 +201,10 @@ typedef struct Namelist Namelist; #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -234,9 +230,6 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } @@ -256,7 +249,6 @@ typedef struct Namelist Namelist; - /* Table of constant values */ static complex c_b1 = {1.f,0.f}; @@ -269,7 +261,6 @@ static integer c__1 = 1; /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download CSPTRF + dependencies */ /* > */ @@ -280,7 +271,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -371,9 +361,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complexOTHERcomputational */ +/* > \ingroup hptrf */ /* > \par Further Details: */ /* ===================== */ @@ -424,15 +412,19 @@ f"> */ { /* System generated locals */ integer i__1, i__2, i__3, i__4, i__5, i__6; - real r__1=0., r__2=0., r__3=0., r__4=0.; - complex q__1={0.,0.}, q__2={0.,0.}, q__3={0.,0.}, q__4={0.,0.}; + real r__1, r__2, r__3, r__4; + complex q__1, q__2, q__3, q__4; /* Local variables */ + integer i__, j, k; + complex t, r1, d11, d12, d21, d22; + integer kc, kk, kp; + complex wk; + integer kx, knc, kpc, npp; + complex wkm1, wkp1; integer imax, jmax; extern /* Subroutine */ void cspr_(char *, integer *, complex *, complex *, integer *, complex *); - integer i__, j, k; - complex t; real alpha; extern /* Subroutine */ void cscal_(integer *, complex *, complex *, integer *); @@ -441,22 +433,17 @@ f"> */ complex *, integer *); integer kstep; logical upper; - complex r1, d11, d12, d21, d22; - integer kc, kk, kp; real absakk; - complex wk; - integer kx; extern integer icamax_(integer *, complex *, integer *); extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - real colmax, rowmax; - integer knc, kpc, npp; - complex wkm1, wkp1; + real colmax; + extern logical sisnan_(real *); + real rowmax; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -525,9 +512,10 @@ f"> */ colmax = 0.f; } - if (f2cmax(absakk,colmax) == 0.f) { + if (f2cmax(absakk,colmax) == 0.f || sisnan_(&absakk)) { -/* Column K is zero: set INFO and continue */ +/* Column K is zero or underflow, or contains a NaN: */ +/* set INFO and continue */ if (*info == 0) { *info = k; @@ -683,32 +671,32 @@ f"> */ d11.r = q__1.r, d11.i = q__1.i; q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * d22.i + d11.i * d22.r; - q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f; c_div(&q__1, &c_b1, &q__2); t.r = q__1.r, t.i = q__1.i; - c_div(&q__1, &t, &d12); - d12.r = q__1.r, d12.i = q__1.i; for (j = k - 2; j >= 1; --j) { i__1 = j + (k - 2) * (k - 1) / 2; - q__3.r = d11.r * ap[i__1].r - d11.i * ap[i__1].i, - q__3.i = d11.r * ap[i__1].i + d11.i * ap[i__1] + q__4.r = d11.r * ap[i__1].r - d11.i * ap[i__1].i, + q__4.i = d11.r * ap[i__1].i + d11.i * ap[i__1] .r; i__2 = j + (k - 1) * k / 2; - q__2.r = q__3.r - ap[i__2].r, q__2.i = q__3.i - ap[ + q__3.r = q__4.r - ap[i__2].r, q__3.i = q__4.i - ap[ i__2].i; - q__1.r = d12.r * q__2.r - d12.i * q__2.i, q__1.i = - d12.r * q__2.i + d12.i * q__2.r; + c_div(&q__2, &q__3, &d12); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; wkm1.r = q__1.r, wkm1.i = q__1.i; i__1 = j + (k - 1) * k / 2; - q__3.r = d22.r * ap[i__1].r - d22.i * ap[i__1].i, - q__3.i = d22.r * ap[i__1].i + d22.i * ap[i__1] + q__4.r = d22.r * ap[i__1].r - d22.i * ap[i__1].i, + q__4.i = d22.r * ap[i__1].i + d22.i * ap[i__1] .r; i__2 = j + (k - 2) * (k - 1) / 2; - q__2.r = q__3.r - ap[i__2].r, q__2.i = q__3.i - ap[ + q__3.r = q__4.r - ap[i__2].r, q__3.i = q__4.i - ap[ i__2].i; - q__1.r = d12.r * q__2.r - d12.i * q__2.i, q__1.i = - d12.r * q__2.i + d12.i * q__2.r; + c_div(&q__2, &q__3, &d12); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; wk.r = q__1.r, wk.i = q__1.i; for (i__ = j; i__ >= 1; --i__) { i__1 = i__ + (j - 1) * j / 2; @@ -794,9 +782,10 @@ f"> */ colmax = 0.f; } - if (f2cmax(absakk,colmax) == 0.f) { + if (f2cmax(absakk,colmax) == 0.f || sisnan_(&absakk)) { -/* Column K is zero: set INFO and continue */ +/* Column K is zero or underflow, or contains a NaN: */ +/* set INFO and continue */ if (*info == 0) { *info = k; @@ -966,33 +955,33 @@ f"> */ d22.r = q__1.r, d22.i = q__1.i; q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * d22.i + d11.i * d22.r; - q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f; c_div(&q__1, &c_b1, &q__2); t.r = q__1.r, t.i = q__1.i; - c_div(&q__1, &t, &d21); - d21.r = q__1.r, d21.i = q__1.i; i__1 = *n; for (j = k + 2; j <= i__1; ++j) { i__2 = j + (k - 1) * ((*n << 1) - k) / 2; - q__3.r = d11.r * ap[i__2].r - d11.i * ap[i__2].i, - q__3.i = d11.r * ap[i__2].i + d11.i * ap[i__2] + q__4.r = d11.r * ap[i__2].r - d11.i * ap[i__2].i, + q__4.i = d11.r * ap[i__2].i + d11.i * ap[i__2] .r; i__3 = j + k * ((*n << 1) - k - 1) / 2; - q__2.r = q__3.r - ap[i__3].r, q__2.i = q__3.i - ap[ + q__3.r = q__4.r - ap[i__3].r, q__3.i = q__4.i - ap[ i__3].i; - q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = - d21.r * q__2.i + d21.i * q__2.r; + c_div(&q__2, &q__3, &d21); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; wk.r = q__1.r, wk.i = q__1.i; i__2 = j + k * ((*n << 1) - k - 1) / 2; - q__3.r = d22.r * ap[i__2].r - d22.i * ap[i__2].i, - q__3.i = d22.r * ap[i__2].i + d22.i * ap[i__2] + q__4.r = d22.r * ap[i__2].r - d22.i * ap[i__2].i, + q__4.i = d22.r * ap[i__2].i + d22.i * ap[i__2] .r; i__3 = j + (k - 1) * ((*n << 1) - k) / 2; - q__2.r = q__3.r - ap[i__3].r, q__2.i = q__3.i - ap[ + q__3.r = q__4.r - ap[i__3].r, q__3.i = q__4.i - ap[ i__3].i; - q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = - d21.r * q__2.i + d21.i * q__2.r; + c_div(&q__2, &q__3, &d21); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; wkp1.r = q__1.r, wkp1.i = q__1.i; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { diff --git a/lapack-netlib/SRC/csptrf.f b/lapack-netlib/SRC/csptrf.f index 64f8e678b6..c7d2d7f414 100644 --- a/lapack-netlib/SRC/csptrf.f +++ b/lapack-netlib/SRC/csptrf.f @@ -375,13 +375,12 @@ SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12 D11 = AP( K+( K-1 )*K / 2 ) / D12 T = CONE / ( D11*D22-CONE ) - D12 = T / D12 * DO 50 J = K - 2, 1, -1 - WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ AP( J+( K-1 )*K / 2 ) ) - WK = D12*( D22*AP( J+( K-1 )*K / 2 )- - $ AP( J+( K-2 )*( K-1 ) / 2 ) ) + WKM1 = T*( ( D11*AP( J+( K-2 )*( K-1 ) / 2 )- + $ AP( J+( K-1 )*K / 2 ) ) / D12 ) + WK = T*( ( D22*AP( J+( K-1 )*K / 2 )- + $ AP( J+( K-2 )*( K-1 ) / 2 ) ) / D12 ) DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*WK - @@ -576,13 +575,12 @@ SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 T = CONE / ( D11*D22-CONE ) - D21 = T / D21 * DO 100 J = K + 2, N - WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- - $ AP( J+K*( 2*N-K-1 ) / 2 ) ) - WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- - $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) + WK = T*( ( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- + $ AP( J+K*( 2*N-K-1 ) / 2 ) ) / D21 ) + WKP1 = T*( ( D22*AP( J+K*( 2*N-K-1 ) / 2 )- + $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) / D21 ) DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / diff --git a/lapack-netlib/SRC/csytf2.c b/lapack-netlib/SRC/csytf2.c index 0637cb1b4e..7253c39019 100644 --- a/lapack-netlib/SRC/csytf2.c +++ b/lapack-netlib/SRC/csytf2.c @@ -182,14 +182,14 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define r_imag(z) (cimagf(Cf(z))) #define c_abs(z) (cabsf(Cf(z))) #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } #ifdef _MSC_VER #define c_div(c, a, b) {float nenn=crealf(_FCmulcc(Cf(b),conjf(Cf(b)))); _Fcomplex zaehl=_FCmulcc(Cf(a),conjf(Cf(b))); pCf(c)=_FCbuild(crealf(zaehl)/nenn,cimagf(zaehl)/nenn);} -#define z_div(c, a, b) {double nenn=creal(_Cmulcc(Cd(b),conj(Cd(b)))); _Dcomplex zaehl=_Cmulcc(Cd(a),conj(Cd(b))); pCd(c)=_Cbuild(creal(zaehl)/nenn,cimag(zaehl)/nenn);} #else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} #endif #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} @@ -201,14 +201,10 @@ typedef struct Namelist Namelist; #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -234,9 +230,6 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } @@ -255,8 +248,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static complex c_b1 = {1.f,0.f}; @@ -270,7 +261,6 @@ oting method (unblocked algorithm). */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download CSYTF2 + dependencies */ /* > */ @@ -281,7 +271,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -391,9 +380,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complexSYcomputational */ +/* > \ingroup hetf2 */ /* > \par Further Details: */ /* ===================== */ @@ -458,15 +445,17 @@ f"> */ { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; - real r__1=0., r__2=0., r__3=0., r__4=0.; - complex q__1={0.,0.}, q__2={0.,0.}, q__3={0.,0.}, q__4={0.,0.}; + real r__1, r__2, r__3, r__4; + complex q__1, q__2, q__3, q__4; /* Local variables */ + integer i__, j, k; + complex t, r1, d11, d12, d21, d22; + integer kk, kp; + complex wk, wkm1, wkp1; integer imax, jmax; extern /* Subroutine */ void csyr_(char *, integer *, complex *, complex *, integer *, complex *, integer *); - integer i__, j, k; - complex t; real alpha; extern /* Subroutine */ void cscal_(integer *, complex *, complex *, integer *); @@ -475,22 +464,17 @@ f"> */ complex *, integer *); integer kstep; logical upper; - complex r1, d11, d12, d21, d22; - integer kk, kp; real absakk; - complex wk; extern integer icamax_(integer *, complex *, integer *); extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); real colmax; extern logical sisnan_(real *); real rowmax; - complex wkm1, wkp1; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -500,7 +484,7 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; @@ -704,32 +688,32 @@ f"> */ d11.r = q__1.r, d11.i = q__1.i; q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * d22.i + d11.i * d22.r; - q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f; c_div(&q__1, &c_b1, &q__2); t.r = q__1.r, t.i = q__1.i; - c_div(&q__1, &t, &d12); - d12.r = q__1.r, d12.i = q__1.i; for (j = k - 2; j >= 1; --j) { i__1 = j + (k - 1) * a_dim1; - q__3.r = d11.r * a[i__1].r - d11.i * a[i__1].i, - q__3.i = d11.r * a[i__1].i + d11.i * a[i__1] + q__4.r = d11.r * a[i__1].r - d11.i * a[i__1].i, + q__4.i = d11.r * a[i__1].i + d11.i * a[i__1] .r; i__2 = j + k * a_dim1; - q__2.r = q__3.r - a[i__2].r, q__2.i = q__3.i - a[i__2] + q__3.r = q__4.r - a[i__2].r, q__3.i = q__4.i - a[i__2] .i; - q__1.r = d12.r * q__2.r - d12.i * q__2.i, q__1.i = - d12.r * q__2.i + d12.i * q__2.r; + c_div(&q__2, &q__3, &d12); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; wkm1.r = q__1.r, wkm1.i = q__1.i; i__1 = j + k * a_dim1; - q__3.r = d22.r * a[i__1].r - d22.i * a[i__1].i, - q__3.i = d22.r * a[i__1].i + d22.i * a[i__1] + q__4.r = d22.r * a[i__1].r - d22.i * a[i__1].i, + q__4.i = d22.r * a[i__1].i + d22.i * a[i__1] .r; i__2 = j + (k - 1) * a_dim1; - q__2.r = q__3.r - a[i__2].r, q__2.i = q__3.i - a[i__2] + q__3.r = q__4.r - a[i__2].r, q__3.i = q__4.i - a[i__2] .i; - q__1.r = d12.r * q__2.r - d12.i * q__2.i, q__1.i = - d12.r * q__2.i + d12.i * q__2.r; + c_div(&q__2, &q__3, &d12); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; wk.r = q__1.r, wk.i = q__1.i; for (i__ = j; i__ >= 1; --i__) { i__1 = i__ + j * a_dim1; @@ -958,33 +942,33 @@ f"> */ d22.r = q__1.r, d22.i = q__1.i; q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * d22.i + d11.i * d22.r; - q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f; c_div(&q__1, &c_b1, &q__2); t.r = q__1.r, t.i = q__1.i; - c_div(&q__1, &t, &d21); - d21.r = q__1.r, d21.i = q__1.i; i__1 = *n; for (j = k + 2; j <= i__1; ++j) { i__2 = j + k * a_dim1; - q__3.r = d11.r * a[i__2].r - d11.i * a[i__2].i, - q__3.i = d11.r * a[i__2].i + d11.i * a[i__2] + q__4.r = d11.r * a[i__2].r - d11.i * a[i__2].i, + q__4.i = d11.r * a[i__2].i + d11.i * a[i__2] .r; i__3 = j + (k + 1) * a_dim1; - q__2.r = q__3.r - a[i__3].r, q__2.i = q__3.i - a[i__3] + q__3.r = q__4.r - a[i__3].r, q__3.i = q__4.i - a[i__3] .i; - q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = - d21.r * q__2.i + d21.i * q__2.r; + c_div(&q__2, &q__3, &d21); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; wk.r = q__1.r, wk.i = q__1.i; i__2 = j + (k + 1) * a_dim1; - q__3.r = d22.r * a[i__2].r - d22.i * a[i__2].i, - q__3.i = d22.r * a[i__2].i + d22.i * a[i__2] + q__4.r = d22.r * a[i__2].r - d22.i * a[i__2].i, + q__4.i = d22.r * a[i__2].i + d22.i * a[i__2] .r; i__3 = j + k * a_dim1; - q__2.r = q__3.r - a[i__3].r, q__2.i = q__3.i - a[i__3] + q__3.r = q__4.r - a[i__3].r, q__3.i = q__4.i - a[i__3] .i; - q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i = - d21.r * q__2.i + d21.i * q__2.r; + c_div(&q__2, &q__3, &d21); + q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * + q__2.i + t.i * q__2.r; wkp1.r = q__1.r, wkp1.i = q__1.i; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { diff --git a/lapack-netlib/SRC/csytf2.f b/lapack-netlib/SRC/csytf2.f index 0bee443189..09228ec9fd 100644 --- a/lapack-netlib/SRC/csytf2.f +++ b/lapack-netlib/SRC/csytf2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CSYTF2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -127,7 +125,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexSYcomputational +*> \ingroup hetf2 * *> \par Further Details: * ===================== @@ -188,6 +186,7 @@ * * ===================================================================== SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -395,11 +394,10 @@ SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = CONE / ( D11*D22-CONE ) - D12 = T / D12 * DO 30 J = K - 2, 1, -1 - WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) ) - WK = D12*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K-1 )*WKM1 @@ -481,7 +479,8 @@ SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), LDA ) ROWMAX = CABS1( A( IMAX, JMAX ) ) IF( IMAX.LT.N ) THEN - JMAX = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 ) + JMAX = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) ROWMAX = MAX( ROWMAX, CABS1( A( JMAX, IMAX ) ) ) END IF * @@ -513,7 +512,8 @@ SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * submatrix A(k:n,k:n) * IF( KP.LT.N ) - $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) CALL CSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), $ LDA ) T = A( KK, KK ) @@ -568,11 +568,10 @@ SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = CONE / ( D11*D22-CONE ) - D21 = T / D21 * DO 60 J = K + 2, N - WK = D21*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) DO 50 I = J, N A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K+1 )*WKP1 diff --git a/lapack-netlib/SRC/csytf2_rk.c b/lapack-netlib/SRC/csytf2_rk.c index 43b8c4b55c..10e781aefc 100644 --- a/lapack-netlib/SRC/csytf2_rk.c +++ b/lapack-netlib/SRC/csytf2_rk.c @@ -182,14 +182,14 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define r_imag(z) (cimagf(Cf(z))) #define c_abs(z) (cabsf(Cf(z))) #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } #ifdef _MSC_VER #define c_div(c, a, b) {float nenn=crealf(_FCmulcc(Cf(b),conjf(Cf(b)))); _Fcomplex zaehl=_FCmulcc(Cf(a),conjf(Cf(b))); pCf(c)=_FCbuild(crealf(zaehl)/nenn,cimagf(zaehl)/nenn);} -#define z_div(c, a, b) {double nenn=creal(_Cmulcc(Cd(b),conj(Cd(b)))); _Dcomplex zaehl=_Cmulcc(Cd(a),conj(Cd(b))); pCd(c)=_Cbuild(creal(zaehl)/nenn,cimag(zaehl)/nenn);} #else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} #endif #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} @@ -201,14 +201,10 @@ typedef struct Namelist Namelist; #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -234,9 +230,6 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } @@ -255,8 +248,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static complex c_b1 = {1.f,0.f}; @@ -270,7 +261,6 @@ static integer c__1 = 1; /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download CSYTF2_RK + dependencies */ /* > */ @@ -281,7 +271,6 @@ rk.f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -472,9 +461,7 @@ rk.f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complexSYcomputational */ +/* > \ingroup hetf2_rk */ /* > \par Further Details: */ /* ===================== */ @@ -507,17 +494,19 @@ rk.f"> */ lda, complex *e, integer *ipiv, integer *info) { /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - real r__1=0., r__2=0.; - complex q__1={0.,0.}, q__2={0.,0.}, q__3={0.,0.}, q__4={0.,0.}, q__5={0.,0.}, q__6={0.,0.}; + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + real r__1, r__2; + complex q__1, q__2, q__3, q__4; /* Local variables */ + integer i__, j, k, p; + complex t, d11, d12, d21, d22; + integer ii, kk, kp; + complex wk, wkm1, wkp1; logical done; integer imax, jmax; extern /* Subroutine */ void csyr_(char *, integer *, complex *, complex *, integer *, complex *, integer *); - integer i__, j, k, p; - complex t; real alpha; extern /* Subroutine */ void cscal_(integer *, complex *, complex *, integer *); @@ -528,21 +517,16 @@ rk.f"> */ integer itemp, kstep; real stemp; logical upper; - complex d11, d12, d21, d22; - integer ii, kk, kp; real absakk; - complex wk; extern integer icamax_(integer *, complex *, integer *); extern real slamch_(char *); extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); real colmax, rowmax; - complex wkm1, wkp1; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -552,7 +536,7 @@ rk.f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --e; --ipiv; @@ -908,29 +892,31 @@ rk.f"> */ d11.r = q__1.r, d11.i = q__1.i; q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * d22.i + d11.i * d22.r; - q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f; c_div(&q__1, &c_b1, &q__2); t.r = q__1.r, t.i = q__1.i; for (j = k - 2; j >= 1; --j) { i__1 = j + (k - 1) * a_dim1; - q__3.r = d11.r * a[i__1].r - d11.i * a[i__1].i, - q__3.i = d11.r * a[i__1].i + d11.i * a[i__1] + q__4.r = d11.r * a[i__1].r - d11.i * a[i__1].i, + q__4.i = d11.r * a[i__1].i + d11.i * a[i__1] .r; i__2 = j + k * a_dim1; - q__2.r = q__3.r - a[i__2].r, q__2.i = q__3.i - a[i__2] + q__3.r = q__4.r - a[i__2].r, q__3.i = q__4.i - a[i__2] .i; + c_div(&q__2, &q__3, &d12); q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i * q__2.r; wkm1.r = q__1.r, wkm1.i = q__1.i; i__1 = j + k * a_dim1; - q__3.r = d22.r * a[i__1].r - d22.i * a[i__1].i, - q__3.i = d22.r * a[i__1].i + d22.i * a[i__1] + q__4.r = d22.r * a[i__1].r - d22.i * a[i__1].i, + q__4.i = d22.r * a[i__1].i + d22.i * a[i__1] .r; i__2 = j + (k - 1) * a_dim1; - q__2.r = q__3.r - a[i__2].r, q__2.i = q__3.i - a[i__2] + q__3.r = q__4.r - a[i__2].r, q__3.i = q__4.i - a[i__2] .i; + c_div(&q__2, &q__3, &d12); q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i * q__2.r; wk.r = q__1.r, wk.i = q__1.i; @@ -938,17 +924,18 @@ rk.f"> */ for (i__ = j; i__ >= 1; --i__) { i__1 = i__ + j * a_dim1; i__2 = i__ + j * a_dim1; - c_div(&q__4, &a[i__ + k * a_dim1], &d12); - q__3.r = q__4.r * wk.r - q__4.i * wk.i, q__3.i = - q__4.r * wk.i + q__4.i * wk.r; + i__3 = i__ + k * a_dim1; + q__3.r = a[i__3].r * wk.r - a[i__3].i * wk.i, + q__3.i = a[i__3].r * wk.i + a[i__3].i * + wk.r; q__2.r = a[i__2].r - q__3.r, q__2.i = a[i__2].i - q__3.i; - c_div(&q__6, &a[i__ + (k - 1) * a_dim1], &d12); - q__5.r = q__6.r * wkm1.r - q__6.i * wkm1.i, - q__5.i = q__6.r * wkm1.i + q__6.i * + i__4 = i__ + (k - 1) * a_dim1; + q__4.r = a[i__4].r * wkm1.r - a[i__4].i * wkm1.i, + q__4.i = a[i__4].r * wkm1.i + a[i__4].i * wkm1.r; - q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - - q__5.i; + q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - + q__4.i; a[i__1].r = q__1.r, a[i__1].i = q__1.i; /* L20: */ } @@ -956,11 +943,9 @@ rk.f"> */ /* Store U(k) and U(k-1) in cols k and k-1 for row J */ i__1 = j + k * a_dim1; - c_div(&q__1, &wk, &d12); - a[i__1].r = q__1.r, a[i__1].i = q__1.i; + a[i__1].r = wk.r, a[i__1].i = wk.i; i__1 = j + (k - 1) * a_dim1; - c_div(&q__1, &wkm1, &d12); - a[i__1].r = q__1.r, a[i__1].i = q__1.i; + a[i__1].r = wkm1.r, a[i__1].i = wkm1.i; /* L30: */ } @@ -1327,32 +1312,34 @@ rk.f"> */ d22.r = q__1.r, d22.i = q__1.i; q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * d22.i + d11.i * d22.r; - q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f; c_div(&q__1, &c_b1, &q__2); t.r = q__1.r, t.i = q__1.i; i__1 = *n; for (j = k + 2; j <= i__1; ++j) { -/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ +/* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J */ i__2 = j + k * a_dim1; - q__3.r = d11.r * a[i__2].r - d11.i * a[i__2].i, - q__3.i = d11.r * a[i__2].i + d11.i * a[i__2] + q__4.r = d11.r * a[i__2].r - d11.i * a[i__2].i, + q__4.i = d11.r * a[i__2].i + d11.i * a[i__2] .r; i__3 = j + (k + 1) * a_dim1; - q__2.r = q__3.r - a[i__3].r, q__2.i = q__3.i - a[i__3] + q__3.r = q__4.r - a[i__3].r, q__3.i = q__4.i - a[i__3] .i; + c_div(&q__2, &q__3, &d21); q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i * q__2.r; wk.r = q__1.r, wk.i = q__1.i; i__2 = j + (k + 1) * a_dim1; - q__3.r = d22.r * a[i__2].r - d22.i * a[i__2].i, - q__3.i = d22.r * a[i__2].i + d22.i * a[i__2] + q__4.r = d22.r * a[i__2].r - d22.i * a[i__2].i, + q__4.i = d22.r * a[i__2].i + d22.i * a[i__2] .r; i__3 = j + k * a_dim1; - q__2.r = q__3.r - a[i__3].r, q__2.i = q__3.i - a[i__3] + q__3.r = q__4.r - a[i__3].r, q__3.i = q__4.i - a[i__3] .i; + c_div(&q__2, &q__3, &d21); q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i * q__2.r; wkp1.r = q__1.r, wkp1.i = q__1.i; @@ -1363,17 +1350,18 @@ rk.f"> */ for (i__ = j; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; i__4 = i__ + j * a_dim1; - c_div(&q__4, &a[i__ + k * a_dim1], &d21); - q__3.r = q__4.r * wk.r - q__4.i * wk.i, q__3.i = - q__4.r * wk.i + q__4.i * wk.r; + i__5 = i__ + k * a_dim1; + q__3.r = a[i__5].r * wk.r - a[i__5].i * wk.i, + q__3.i = a[i__5].r * wk.i + a[i__5].i * + wk.r; q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i - q__3.i; - c_div(&q__6, &a[i__ + (k + 1) * a_dim1], &d21); - q__5.r = q__6.r * wkp1.r - q__6.i * wkp1.i, - q__5.i = q__6.r * wkp1.i + q__6.i * + i__6 = i__ + (k + 1) * a_dim1; + q__4.r = a[i__6].r * wkp1.r - a[i__6].i * wkp1.i, + q__4.i = a[i__6].r * wkp1.i + a[i__6].i * wkp1.r; - q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - - q__5.i; + q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - + q__4.i; a[i__3].r = q__1.r, a[i__3].i = q__1.i; /* L50: */ } @@ -1381,11 +1369,9 @@ rk.f"> */ /* Store L(k) and L(k+1) in cols k and k+1 for row J */ i__2 = j + k * a_dim1; - c_div(&q__1, &wk, &d21); - a[i__2].r = q__1.r, a[i__2].i = q__1.i; + a[i__2].r = wk.r, a[i__2].i = wk.i; i__2 = j + (k + 1) * a_dim1; - c_div(&q__1, &wkp1, &d21); - a[i__2].r = q__1.r, a[i__2].i = q__1.i; + a[i__2].r = wkp1.r, a[i__2].i = wkp1.i; /* L60: */ } diff --git a/lapack-netlib/SRC/csytf2_rk.f b/lapack-netlib/SRC/csytf2_rk.f index 12d6d5d8f9..a52f69a0b3 100644 --- a/lapack-netlib/SRC/csytf2_rk.f +++ b/lapack-netlib/SRC/csytf2_rk.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CSYTF2_RK + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -208,7 +206,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexSYcomputational +*> \ingroup hetf2_rk * *> \par Further Details: * ===================== @@ -238,6 +236,7 @@ * * ===================================================================== SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -469,7 +468,8 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * the interchanges in columns k+1:N. * IF( K.LT.N ) - $ CALL CSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA ) + $ CALL CSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), + $ LDA ) * END IF * @@ -484,7 +484,8 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) IF( KP.GT.1 ) $ CALL CSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) - $ CALL CSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ CALL CSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, + $ KP+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) @@ -526,7 +527,8 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * = A - W(k)*1/D(k)*W(k)**T * D11 = CONE / A( K, K ) - CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) * * Store U(k) in column k * @@ -545,7 +547,8 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * = A - W(k)*(1/D(k))*W(k)**T * = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T * - CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) END IF * * Store the superdiagonal element of D in array E @@ -579,18 +582,18 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) - WK = T*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - - $ ( A( I, K-1 ) / D12 )*WKM1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K-1 )*WKM1 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D12 - A( J, K-1 ) = WKM1 / D12 + A( J, K ) = WK + A( J, K-1 ) = WKM1 * 30 CONTINUE * @@ -703,14 +706,16 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * Determine both ROWMAX and JMAX. * IF( IMAX.NE.K ) THEN - JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), LDA ) + JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), + $ LDA ) ROWMAX = CABS1( A( IMAX, JMAX ) ) ELSE ROWMAX = ZERO END IF * IF( IMAX.LT.N ) THEN - ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ), + ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, + $ IMAX ), $ 1 ) STEMP = CABS1( A( ITEMP, IMAX ) ) IF( STEMP.GT.ROWMAX ) THEN @@ -769,7 +774,8 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) IF( P.LT.N ) $ CALL CSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) IF( P.GT.(K+1) ) - $ CALL CSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + $ CALL CSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), + $ LDA ) T = A( K, K ) A( K, K ) = A( P, P ) A( P, P ) = T @@ -791,9 +797,11 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * submatrix A(k:n,k:n) * IF( KP.LT.N ) - $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) - $ CALL CSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ CALL CSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, + $ KK+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) @@ -890,22 +898,22 @@ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N - A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - - $ ( A( I, K+1 ) / D21 )*WKP1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K+1 )*WKP1 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D21 - A( J, K+1 ) = WKP1 / D21 + A( J, K ) = WK + A( J, K+1 ) = WKP1 * 60 CONTINUE * diff --git a/lapack-netlib/SRC/csytf2_rook.c b/lapack-netlib/SRC/csytf2_rook.c index 9e8f91dd7a..57dad03758 100644 --- a/lapack-netlib/SRC/csytf2_rook.c +++ b/lapack-netlib/SRC/csytf2_rook.c @@ -182,14 +182,14 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define r_imag(z) (cimagf(Cf(z))) #define c_abs(z) (cabsf(Cf(z))) #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } #ifdef _MSC_VER #define c_div(c, a, b) {float nenn=crealf(_FCmulcc(Cf(b),conjf(Cf(b)))); _Fcomplex zaehl=_FCmulcc(Cf(a),conjf(Cf(b))); pCf(c)=_FCbuild(crealf(zaehl)/nenn,cimagf(zaehl)/nenn);} -#define z_div(c, a, b) {double nenn=creal(_Cmulcc(Cd(b),conj(Cd(b)))); _Dcomplex zaehl=_Cmulcc(Cd(a),conj(Cd(b))); pCd(c)=_Cbuild(creal(zaehl)/nenn,cimag(zaehl)/nenn);} #else #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} #endif #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} @@ -201,14 +201,10 @@ typedef struct Namelist Namelist; #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -234,9 +230,6 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } @@ -255,8 +248,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static complex c_b1 = {1.f,0.f}; @@ -270,7 +261,6 @@ ed Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm). */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download CSYTF2_ROOK + dependencies */ /* > */ @@ -281,7 +271,6 @@ rook.f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -393,9 +382,7 @@ rook.f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date November 2013 */ - -/* > \ingroup complexSYcomputational */ +/* > \ingroup hetf2_rook */ /* > \par Further Details: */ /* ===================== */ @@ -460,17 +447,19 @@ rook.f"> */ integer *lda, integer *ipiv, integer *info) { /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - real r__1=0., r__2=0.; - complex q__1={0.,0.}, q__2={0.,0.}, q__3={0.,0.}, q__4={0.,0.}, q__5={0.,0.}, q__6={0.,0.}; + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + real r__1, r__2; + complex q__1, q__2, q__3, q__4; /* Local variables */ + integer i__, j, k, p; + complex t, d11, d12, d21, d22; + integer ii, kk, kp; + complex wk, wkm1, wkp1; logical done; integer imax, jmax; extern /* Subroutine */ void csyr_(char *, integer *, complex *, complex *, integer *, complex *, integer *); - integer i__, j, k, p; - complex t; real alpha; extern /* Subroutine */ void cscal_(integer *, complex *, complex *, integer *); @@ -481,21 +470,16 @@ rook.f"> */ integer itemp, kstep; real stemp; logical upper; - complex d11, d12, d21, d22; - integer ii, kk, kp; real absakk; - complex wk; extern integer icamax_(integer *, complex *, integer *); extern real slamch_(char *); extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); real colmax, rowmax; - complex wkm1, wkp1; -/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* November 2013 */ /* ===================================================================== */ @@ -505,7 +489,7 @@ rook.f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; @@ -821,29 +805,31 @@ rook.f"> */ d11.r = q__1.r, d11.i = q__1.i; q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * d22.i + d11.i * d22.r; - q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f; c_div(&q__1, &c_b1, &q__2); t.r = q__1.r, t.i = q__1.i; for (j = k - 2; j >= 1; --j) { i__1 = j + (k - 1) * a_dim1; - q__3.r = d11.r * a[i__1].r - d11.i * a[i__1].i, - q__3.i = d11.r * a[i__1].i + d11.i * a[i__1] + q__4.r = d11.r * a[i__1].r - d11.i * a[i__1].i, + q__4.i = d11.r * a[i__1].i + d11.i * a[i__1] .r; i__2 = j + k * a_dim1; - q__2.r = q__3.r - a[i__2].r, q__2.i = q__3.i - a[i__2] + q__3.r = q__4.r - a[i__2].r, q__3.i = q__4.i - a[i__2] .i; + c_div(&q__2, &q__3, &d12); q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i * q__2.r; wkm1.r = q__1.r, wkm1.i = q__1.i; i__1 = j + k * a_dim1; - q__3.r = d22.r * a[i__1].r - d22.i * a[i__1].i, - q__3.i = d22.r * a[i__1].i + d22.i * a[i__1] + q__4.r = d22.r * a[i__1].r - d22.i * a[i__1].i, + q__4.i = d22.r * a[i__1].i + d22.i * a[i__1] .r; i__2 = j + (k - 1) * a_dim1; - q__2.r = q__3.r - a[i__2].r, q__2.i = q__3.i - a[i__2] + q__3.r = q__4.r - a[i__2].r, q__3.i = q__4.i - a[i__2] .i; + c_div(&q__2, &q__3, &d12); q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i * q__2.r; wk.r = q__1.r, wk.i = q__1.i; @@ -851,17 +837,18 @@ rook.f"> */ for (i__ = j; i__ >= 1; --i__) { i__1 = i__ + j * a_dim1; i__2 = i__ + j * a_dim1; - c_div(&q__4, &a[i__ + k * a_dim1], &d12); - q__3.r = q__4.r * wk.r - q__4.i * wk.i, q__3.i = - q__4.r * wk.i + q__4.i * wk.r; + i__3 = i__ + k * a_dim1; + q__3.r = a[i__3].r * wk.r - a[i__3].i * wk.i, + q__3.i = a[i__3].r * wk.i + a[i__3].i * + wk.r; q__2.r = a[i__2].r - q__3.r, q__2.i = a[i__2].i - q__3.i; - c_div(&q__6, &a[i__ + (k - 1) * a_dim1], &d12); - q__5.r = q__6.r * wkm1.r - q__6.i * wkm1.i, - q__5.i = q__6.r * wkm1.i + q__6.i * + i__4 = i__ + (k - 1) * a_dim1; + q__4.r = a[i__4].r * wkm1.r - a[i__4].i * wkm1.i, + q__4.i = a[i__4].r * wkm1.i + a[i__4].i * wkm1.r; - q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - - q__5.i; + q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - + q__4.i; a[i__1].r = q__1.r, a[i__1].i = q__1.i; /* L20: */ } @@ -869,11 +856,9 @@ rook.f"> */ /* Store U(k) and U(k-1) in cols k and k-1 for row J */ i__1 = j + k * a_dim1; - c_div(&q__1, &wk, &d12); - a[i__1].r = q__1.r, a[i__1].i = q__1.i; + a[i__1].r = wk.r, a[i__1].i = wk.i; i__1 = j + (k - 1) * a_dim1; - c_div(&q__1, &wkm1, &d12); - a[i__1].r = q__1.r, a[i__1].i = q__1.i; + a[i__1].r = wkm1.r, a[i__1].i = wkm1.i; /* L30: */ } @@ -1185,32 +1170,34 @@ rook.f"> */ d22.r = q__1.r, d22.i = q__1.i; q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r * d22.i + d11.i * d22.r; - q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; + q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f; c_div(&q__1, &c_b1, &q__2); t.r = q__1.r, t.i = q__1.i; i__1 = *n; for (j = k + 2; j <= i__1; ++j) { -/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ +/* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J */ i__2 = j + k * a_dim1; - q__3.r = d11.r * a[i__2].r - d11.i * a[i__2].i, - q__3.i = d11.r * a[i__2].i + d11.i * a[i__2] + q__4.r = d11.r * a[i__2].r - d11.i * a[i__2].i, + q__4.i = d11.r * a[i__2].i + d11.i * a[i__2] .r; i__3 = j + (k + 1) * a_dim1; - q__2.r = q__3.r - a[i__3].r, q__2.i = q__3.i - a[i__3] + q__3.r = q__4.r - a[i__3].r, q__3.i = q__4.i - a[i__3] .i; + c_div(&q__2, &q__3, &d21); q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i * q__2.r; wk.r = q__1.r, wk.i = q__1.i; i__2 = j + (k + 1) * a_dim1; - q__3.r = d22.r * a[i__2].r - d22.i * a[i__2].i, - q__3.i = d22.r * a[i__2].i + d22.i * a[i__2] + q__4.r = d22.r * a[i__2].r - d22.i * a[i__2].i, + q__4.i = d22.r * a[i__2].i + d22.i * a[i__2] .r; i__3 = j + k * a_dim1; - q__2.r = q__3.r - a[i__3].r, q__2.i = q__3.i - a[i__3] + q__3.r = q__4.r - a[i__3].r, q__3.i = q__4.i - a[i__3] .i; + c_div(&q__2, &q__3, &d21); q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i * q__2.r; wkp1.r = q__1.r, wkp1.i = q__1.i; @@ -1221,17 +1208,18 @@ rook.f"> */ for (i__ = j; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; i__4 = i__ + j * a_dim1; - c_div(&q__4, &a[i__ + k * a_dim1], &d21); - q__3.r = q__4.r * wk.r - q__4.i * wk.i, q__3.i = - q__4.r * wk.i + q__4.i * wk.r; + i__5 = i__ + k * a_dim1; + q__3.r = a[i__5].r * wk.r - a[i__5].i * wk.i, + q__3.i = a[i__5].r * wk.i + a[i__5].i * + wk.r; q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i - q__3.i; - c_div(&q__6, &a[i__ + (k + 1) * a_dim1], &d21); - q__5.r = q__6.r * wkp1.r - q__6.i * wkp1.i, - q__5.i = q__6.r * wkp1.i + q__6.i * + i__6 = i__ + (k + 1) * a_dim1; + q__4.r = a[i__6].r * wkp1.r - a[i__6].i * wkp1.i, + q__4.i = a[i__6].r * wkp1.i + a[i__6].i * wkp1.r; - q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - - q__5.i; + q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - + q__4.i; a[i__3].r = q__1.r, a[i__3].i = q__1.i; /* L50: */ } @@ -1239,11 +1227,9 @@ rook.f"> */ /* Store L(k) and L(k+1) in cols k and k+1 for row J */ i__2 = j + k * a_dim1; - c_div(&q__1, &wk, &d21); - a[i__2].r = q__1.r, a[i__2].i = q__1.i; + a[i__2].r = wk.r, a[i__2].i = wk.i; i__2 = j + (k + 1) * a_dim1; - c_div(&q__1, &wkp1, &d21); - a[i__2].r = q__1.r, a[i__2].i = q__1.i; + a[i__2].r = wkp1.r, a[i__2].i = wkp1.i; /* L60: */ } diff --git a/lapack-netlib/SRC/csytf2_rook.f b/lapack-netlib/SRC/csytf2_rook.f index 5ae4c98036..50f2894b4a 100644 --- a/lapack-netlib/SRC/csytf2_rook.f +++ b/lapack-netlib/SRC/csytf2_rook.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CSYTF2_ROOK + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -129,7 +127,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexSYcomputational +*> \ingroup hetf2_rook * *> \par Further Details: * ===================== @@ -191,6 +189,7 @@ * * ===================================================================== SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -418,7 +417,8 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) IF( KP.GT.1 ) $ CALL CSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) - $ CALL CSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ CALL CSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, + $ KP+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) @@ -452,7 +452,8 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * = A - W(k)*1/D(k)*W(k)**T * D11 = CONE / A( K, K ) - CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) * * Store U(k) in column k * @@ -471,7 +472,8 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * = A - W(k)*(1/D(k))*W(k)**T * = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T * - CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) END IF END IF * @@ -500,18 +502,18 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) - WK = T*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - - $ ( A( I, K-1 ) / D12 )*WKM1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K-1 )*WKM1 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D12 - A( J, K-1 ) = WKM1 / D12 + A( J, K ) = WK + A( J, K-1 ) = WKM1 * 30 CONTINUE * @@ -601,14 +603,16 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * Determine both ROWMAX and JMAX. * IF( IMAX.NE.K ) THEN - JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), LDA ) + JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), + $ LDA ) ROWMAX = CABS1( A( IMAX, JMAX ) ) ELSE ROWMAX = ZERO END IF * IF( IMAX.LT.N ) THEN - ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ), + ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, + $ IMAX ), $ 1 ) STEMP = CABS1( A( ITEMP, IMAX ) ) IF( STEMP.GT.ROWMAX ) THEN @@ -667,7 +671,8 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) IF( P.LT.N ) $ CALL CSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) IF( P.GT.(K+1) ) - $ CALL CSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + $ CALL CSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), + $ LDA ) T = A( K, K ) A( K, K ) = A( P, P ) A( P, P ) = T @@ -682,9 +687,11 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * submatrix A(k:n,k:n) * IF( KP.LT.N ) - $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) - $ CALL CSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ CALL CSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, + $ KK+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) @@ -769,22 +776,22 @@ SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N - A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - - $ ( A( I, K+1 ) / D21 )*WKP1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K+1 )*WKP1 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D21 - A( J, K+1 ) = WKP1 / D21 + A( J, K ) = WK + A( J, K+1 ) = WKP1 * 60 CONTINUE * diff --git a/lapack-netlib/SRC/dlasyf.c b/lapack-netlib/SRC/dlasyf.c index 964ce587a6..a340faf6c1 100644 --- a/lapack-netlib/SRC/dlasyf.c +++ b/lapack-netlib/SRC/dlasyf.c @@ -225,9 +225,6 @@ typedef struct Namelist Namelist; -lf2c -lm (in that order) */ - - - /* Table of constant values */ static integer c__1 = 1; @@ -242,7 +239,6 @@ onal pivoting method. */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download DLASYF + dependencies */ /* > */ @@ -253,7 +249,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -395,9 +390,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date November 2013 */ - -/* > \ingroup doubleSYcomputational */ +/* > \ingroup lahef */ /* > \par Contributors: */ /* ================== */ @@ -415,16 +408,16 @@ f"> */ ldw, integer *info) { /* System generated locals */ - integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2; doublereal d__1, d__2, d__3; /* Local variables */ - integer imax, jmax, j, k; - doublereal t, alpha; + integer j, k; + doublereal t, r1, d11, d21, d22; + integer jj, kk, jp, kp, kw, kkw, imax, jmax; + doublereal alpha; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, - integer *), dgemm_(char *, char *, integer *, integer *, integer * - , doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *); + integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ void dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, @@ -432,19 +425,17 @@ f"> */ doublereal *, integer *, doublereal *, integer *), dswap_(integer *, doublereal *, integer *, doublereal *, integer *); integer kstep; - doublereal r1, d11, d21, d22; - integer jb, jj, kk, jp, kp; doublereal absakk; - integer kw; extern integer idamax_(integer *, doublereal *, integer *); doublereal colmax, rowmax; - integer kkw; + extern /* Subroutine */ void dgemmtr_(char *, char *, char *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); -/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* November 2013 */ /* ===================================================================== */ @@ -452,11 +443,11 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; w_dim1 = *ldw; - w_offset = 1 + w_dim1 * 1; + w_offset = 1 + w_dim1; w -= w_offset; /* Function Body */ @@ -482,7 +473,7 @@ f"> */ /* Exit from loop */ - if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { goto L30; } @@ -523,6 +514,7 @@ f"> */ *info = k; } kp = k; + dcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); } else { if (absakk >= alpha * colmax) { @@ -695,14 +687,14 @@ f"> */ /* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */ /* ( ( -1 ) ( D22 ) ) */ -/* = D21 * ( ( D11 ) ( -1 ) ) */ -/* ( ( -1 ) ( D22 ) ) */ +/* T/d21 is not formed, since it overflows when d21 is */ +/* subnormal: each entry of the product is divided by */ +/* d21 and then scaled by T. */ d21 = w[k - 1 + kw * w_dim1]; d11 = w[k + kw * w_dim1] / d21; d22 = w[k - 1 + (kw - 1) * w_dim1] / d21; t = 1. / (d11 * d22 - 1.); - d21 = t / d21; /* Update elements in columns A(k-1) and A(k) as */ /* dot products of rows of ( W(kw-1) W(kw) ) and columns */ @@ -710,10 +702,10 @@ f"> */ i__1 = k - 2; for (j = 1; j <= i__1; ++j) { - a[j + (k - 1) * a_dim1] = d21 * (d11 * w[j + (kw - 1) - * w_dim1] - w[j + kw * w_dim1]); - a[j + k * a_dim1] = d21 * (d22 * w[j + kw * w_dim1] - - w[j + (kw - 1) * w_dim1]); + a[j + (k - 1) * a_dim1] = t * ((d11 * w[j + (kw - 1) * + w_dim1] - w[j + kw * w_dim1]) / d21); + a[j + k * a_dim1] = t * ((d22 * w[j + kw * w_dim1] - + w[j + (kw - 1) * w_dim1]) / d21); /* L20: */ } } @@ -748,36 +740,10 @@ f"> */ /* A11 := A11 - U12*D*U12**T = A11 - U12*W**T */ -/* computing blocks of NB columns at a time */ - - i__1 = -(*nb); - for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += - i__1) { -/* Computing MIN */ - i__2 = *nb, i__3 = k - j + 1; - jb = f2cmin(i__2,i__3); - -/* Update the upper triangle of the diagonal block */ - - i__2 = j + jb - 1; - for (jj = j; jj <= i__2; ++jj) { - i__3 = jj - j + 1; - i__4 = *n - k; - dgemv_("No transpose", &i__3, &i__4, &c_b8, &a[j + (k + 1) * - a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b9, - &a[j + jj * a_dim1], &c__1); -/* L40: */ - } - -/* Update the rectangular superdiagonal block */ - - i__2 = j - 1; - i__3 = *n - k; - dgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &c_b8, &a[( - k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw, - &c_b9, &a[j * a_dim1 + 1], lda); -/* L50: */ - } + i__1 = *n - k; + dgemmtr_("Upper", "No transpose", "Transpose", &k, &i__1, &c_b8, &a[( + k + 1) * a_dim1 + 1], lda, &w[(kw + 1) * w_dim1 + 1], ldw, & + c_b9, &a[a_dim1 + 1], lda); /* Put U12 in standard form by partially undoing the interchanges */ /* in columns k+1:n looping backwards from k+1 to n */ @@ -824,7 +790,7 @@ f"> */ /* Exit from loop */ - if ((k >= *nb && *nb < *n) || k > *n) { + if (k >= *nb && *nb < *n || k > *n) { goto L90; } @@ -864,6 +830,9 @@ f"> */ *info = k; } kp = k; + i__1 = *n - k + 1; + dcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); } else { if (absakk >= alpha * colmax) { @@ -1034,14 +1003,14 @@ f"> */ /* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */ /* ( ( -1 ) ( D22 ) ) */ -/* = D21 * ( ( D11 ) ( -1 ) ) */ -/* ( ( -1 ) ( D22 ) ) */ +/* T/d21 is not formed, since it overflows when d21 is */ +/* subnormal: each entry of the product is divided by */ +/* d21 and then scaled by T. */ d21 = w[k + 1 + k * w_dim1]; d11 = w[k + 1 + (k + 1) * w_dim1] / d21; d22 = w[k + k * w_dim1] / d21; t = 1. / (d11 * d22 - 1.); - d21 = t / d21; /* Update elements in columns A(k) and A(k+1) as */ /* dot products of rows of ( W(k) W(k+1) ) and columns */ @@ -1049,10 +1018,10 @@ f"> */ i__1 = *n; for (j = k + 2; j <= i__1; ++j) { - a[j + k * a_dim1] = d21 * (d11 * w[j + k * w_dim1] - - w[j + (k + 1) * w_dim1]); - a[j + (k + 1) * a_dim1] = d21 * (d22 * w[j + (k + 1) * - w_dim1] - w[j + k * w_dim1]); + a[j + k * a_dim1] = t * ((d11 * w[j + k * w_dim1] - w[ + j + (k + 1) * w_dim1]) / d21); + a[j + (k + 1) * a_dim1] = t * ((d22 * w[j + (k + 1) * + w_dim1] - w[j + k * w_dim1]) / d21); /* L80: */ } } @@ -1087,38 +1056,11 @@ f"> */ /* A22 := A22 - L21*D*L21**T = A22 - L21*W**T */ -/* computing blocks of NB columns at a time */ - - i__1 = *n; - i__2 = *nb; - for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { -/* Computing MIN */ - i__3 = *nb, i__4 = *n - j + 1; - jb = f2cmin(i__3,i__4); - -/* Update the lower triangle of the diagonal block */ - - i__3 = j + jb - 1; - for (jj = j; jj <= i__3; ++jj) { - i__4 = j + jb - jj; - i__5 = k - 1; - dgemv_("No transpose", &i__4, &i__5, &c_b8, &a[jj + a_dim1], - lda, &w[jj + w_dim1], ldw, &c_b9, &a[jj + jj * a_dim1] - , &c__1); -/* L100: */ - } - -/* Update the rectangular subdiagonal block */ - - if (j + jb <= *n) { - i__3 = *n - j - jb + 1; - i__4 = k - 1; - dgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &c_b8, - &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b9, - &a[j + jb + j * a_dim1], lda); - } -/* L110: */ - } + i__1 = *n - k + 1; + i__2 = k - 1; + dgemmtr_("Lower", "No transpose", "Transpose", &i__1, &i__2, &c_b8, & + a[k + a_dim1], lda, &w[k + w_dim1], ldw, &c_b9, &a[k + k * + a_dim1], lda); /* Put L21 in standard form by partially undoing the interchanges */ /* of rows in columns 1:k-1 looping backwards from k-1 to 1 */ diff --git a/lapack-netlib/SRC/dlasyf.f b/lapack-netlib/SRC/dlasyf.f index 3064f5e1e4..5deb395d9d 100644 --- a/lapack-netlib/SRC/dlasyf.f +++ b/lapack-netlib/SRC/dlasyf.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DLASYF + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -159,7 +157,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup doubleSYcomputational +*> \ingroup lahef * *> \par Contributors: * ================== @@ -172,7 +170,9 @@ *> \endverbatim * * ===================================================================== - SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) + SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, + $ INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -196,7 +196,7 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) * .. * .. Local Scalars .. - INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP, + INTEGER IMAX, J, JJ, JMAX, JP, K, KK, KKW, KP, $ KSTEP, KW DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1, $ ROWMAX, T @@ -207,7 +207,7 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) EXTERNAL LSAME, IDAMAX * .. * .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP + EXTERNAL DCOPY, DGEMMTR, DGEMV, DSCAL, DSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT @@ -243,7 +243,8 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) IF( K.LT.N ) - $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), LDA, + $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), + $ LDA, $ W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 ) * KSTEP = 1 @@ -271,6 +272,7 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * @@ -285,7 +287,8 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, $ W( IMAX+1, KW-1 ), 1 ) IF( K.LT.N ) - $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), + $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, + $ K+1 ), $ LDA, W( IMAX, KW+1 ), LDW, ONE, $ W( 1, KW-1 ), 1 ) * @@ -422,22 +425,24 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* = D21 * ( ( D11 ) ( -1 ) ) -* ( ( -1 ) ( D22 ) ) +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 D22 = W( K-1, KW-1 ) / D21 T = ONE / ( D11*D22-ONE ) - D21 = T / D21 * * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) * DO 20 J = 1, K - 2 - A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) - A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D21 ) 20 CONTINUE END IF * @@ -471,25 +476,9 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * A11 := A11 - U12*D*U12**T = A11 - U12*W**T * -* computing blocks of NB columns at a time -* - DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB - JB = MIN( NB, K-J+1 ) -* -* Update the upper triangle of the diagonal block -* - DO 40 JJ = J, J + JB - 1 - CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE, - $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, - $ A( J, JJ ), 1 ) - 40 CONTINUE -* -* Update the rectangular superdiagonal block -* - CALL DGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, -ONE, - $ A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE, - $ A( 1, J ), LDA ) - 50 CONTINUE + CALL DGEMMTR( 'Upper', 'No transpose', 'Transpose', K, N-K, + $ -ONE, A( 1, K+1 ), LDA, W( 1, KW+1 ), LDW, + $ ONE, A( 1, 1 ), LDA ) * * Put U12 in standard form by partially undoing the interchanges * in columns k+1:n looping backwards from k+1 to n @@ -539,7 +528,8 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * Copy column K of A to column K of W and update it * CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) - CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), LDA, + CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), + $ LDA, $ W( K, 1 ), LDW, ONE, W( K, K ), 1 ) * KSTEP = 1 @@ -567,6 +557,7 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * @@ -577,10 +568,13 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * Copy column IMAX to column K+1 of W and update it * - CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 ) - CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ), + CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), + $ 1 ) + CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, + $ K+1 ), $ 1 ) - CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), + CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, + $ 1 ), $ LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 ) * * JMAX is the column-index of the largest off-diagonal @@ -638,7 +632,8 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) CALL DCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), $ LDA ) IF( KP.LT.N ) - $ CALL DCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL DCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) * * Interchange rows KK and KP in first K-1 columns of A * (columns K (or K and K+1 for 2-by-2 pivot) of A will be @@ -712,22 +707,24 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* = D21 * ( ( D11 ) ( -1 ) ) -* ( ( -1 ) ( D22 ) ) +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = ONE / ( D11*D22-ONE ) - D21 = T / D21 * * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) * DO 80 J = K + 2, N - A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) - A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * @@ -761,26 +758,9 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * A22 := A22 - L21*D*L21**T = A22 - L21*W**T * -* computing blocks of NB columns at a time -* - DO 110 J = K, N, NB - JB = MIN( NB, N-J+1 ) -* -* Update the lower triangle of the diagonal block -* - DO 100 JJ = J, J + JB - 1 - CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE, - $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, - $ A( JJ, JJ ), 1 ) - 100 CONTINUE -* -* Update the rectangular subdiagonal block -* - IF( J+JB.LE.N ) - $ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, - $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW, - $ ONE, A( J+JB, J ), LDA ) - 110 CONTINUE + CALL DGEMMTR( 'Lower', 'No transpose', 'Transpose', N-K+1, + $ K-1, -ONE, A( K, 1 ), LDA, W( K, 1 ), LDW, + $ ONE, A( K, K ), LDA ) * * Put L21 in standard form by partially undoing the interchanges * of rows in columns 1:k-1 looping backwards from k-1 to 1 diff --git a/lapack-netlib/SRC/dsptrf.c b/lapack-netlib/SRC/dsptrf.c index 08a245125d..7d55495b6a 100644 --- a/lapack-netlib/SRC/dsptrf.c +++ b/lapack-netlib/SRC/dsptrf.c @@ -226,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__1 = 1; @@ -239,7 +237,6 @@ static integer c__1 = 1; /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download DSPTRF + dependencies */ /* > */ @@ -250,7 +247,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -340,9 +336,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup doubleOTHERcomputational */ +/* > \ingroup hptrf */ /* > \par Further Details: */ /* ===================== */ @@ -398,11 +392,16 @@ f"> */ doublereal d__1, d__2, d__3; /* Local variables */ + integer i__, j, k; + doublereal t, r1, d11, d12, d21, d22; + integer kc, kk, kp; + doublereal wk; + integer kx, knc, kpc, npp; + doublereal wkm1, wkp1; integer imax, jmax; extern /* Subroutine */ void dspr_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *); - integer i__, j, k; - doublereal t, alpha; + doublereal alpha; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); @@ -410,21 +409,16 @@ f"> */ doublereal *, integer *); integer kstep; logical upper; - doublereal r1, d11, d12, d21, d22; - integer kc, kk, kp; - doublereal absakk, wk; - integer kx; + doublereal absakk; extern integer idamax_(integer *, doublereal *, integer *); + extern logical disnan_(doublereal *); extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); doublereal colmax, rowmax; - integer knc, kpc, npp; - doublereal wkm1, wkp1; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -489,9 +483,10 @@ f"> */ colmax = 0.; } - if (f2cmax(absakk,colmax) == 0.) { + if (f2cmax(absakk,colmax) == 0. || disnan_(&absakk)) { -/* Column K is zero: set INFO and continue */ +/* Column K is zero or underflow, or contains a NaN: */ +/* set INFO and continue */ if (*info == 0) { *info = k; @@ -622,13 +617,12 @@ f"> */ d22 = ap[k - 1 + (k - 2) * (k - 1) / 2] / d12; d11 = ap[k + (k - 1) * k / 2] / d12; t = 1. / (d11 * d22 - 1.); - d12 = t / d12; for (j = k - 2; j >= 1; --j) { - wkm1 = d12 * (d11 * ap[j + (k - 2) * (k - 1) / 2] - - ap[j + (k - 1) * k / 2]); - wk = d12 * (d22 * ap[j + (k - 1) * k / 2] - ap[j + (k - - 2) * (k - 1) / 2]); + wkm1 = t * ((d11 * ap[j + (k - 2) * (k - 1) / 2] - ap[ + j + (k - 1) * k / 2]) / d12); + wk = t * ((d22 * ap[j + (k - 1) * k / 2] - ap[j + (k + - 2) * (k - 1) / 2]) / d12); for (i__ = j; i__ >= 1; --i__) { ap[i__ + (j - 1) * j / 2] = ap[i__ + (j - 1) * j / 2] - ap[i__ + (k - 1) * k / 2] * wk - ap[ @@ -696,9 +690,10 @@ f"> */ colmax = 0.; } - if (f2cmax(absakk,colmax) == 0.) { + if (f2cmax(absakk,colmax) == 0. || disnan_(&absakk)) { -/* Column K is zero: set INFO and continue */ +/* Column K is zero or underflow, or contains a NaN: */ +/* set INFO and continue */ if (*info == 0) { *info = k; @@ -840,14 +835,15 @@ f"> */ d11 = ap[k + 1 + k * ((*n << 1) - k - 1) / 2] / d21; d22 = ap[k + (k - 1) * ((*n << 1) - k) / 2] / d21; t = 1. / (d11 * d22 - 1.); - d21 = t / d21; i__1 = *n; for (j = k + 2; j <= i__1; ++j) { - wk = d21 * (d11 * ap[j + (k - 1) * ((*n << 1) - k) / - 2] - ap[j + k * ((*n << 1) - k - 1) / 2]); - wkp1 = d21 * (d22 * ap[j + k * ((*n << 1) - k - 1) / - 2] - ap[j + (k - 1) * ((*n << 1) - k) / 2]); + wk = t * ((d11 * ap[j + (k - 1) * ((*n << 1) - k) / 2] + - ap[j + k * ((*n << 1) - k - 1) / 2]) / d21) + ; + wkp1 = t * ((d22 * ap[j + k * ((*n << 1) - k - 1) / 2] + - ap[j + (k - 1) * ((*n << 1) - k) / 2]) / + d21); i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { diff --git a/lapack-netlib/SRC/dsptrf.f b/lapack-netlib/SRC/dsptrf.f index acd0290435..2a05f0138b 100644 --- a/lapack-netlib/SRC/dsptrf.f +++ b/lapack-netlib/SRC/dsptrf.f @@ -368,13 +368,12 @@ SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12 D11 = AP( K+( K-1 )*K / 2 ) / D12 T = ONE / ( D11*D22-ONE ) - D12 = T / D12 * DO 50 J = K - 2, 1, -1 - WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ AP( J+( K-1 )*K / 2 ) ) - WK = D12*( D22*AP( J+( K-1 )*K / 2 )- - $ AP( J+( K-2 )*( K-1 ) / 2 ) ) + WKM1 = T*( ( D11*AP( J+( K-2 )*( K-1 ) / 2 )- + $ AP( J+( K-1 )*K / 2 ) ) / D12 ) + WK = T*( ( D22*AP( J+( K-1 )*K / 2 )- + $ AP( J+( K-2 )*( K-1 ) / 2 ) ) / D12 ) DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*WK - @@ -570,13 +569,12 @@ SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 T = ONE / ( D11*D22-ONE ) - D21 = T / D21 * DO 100 J = K + 2, N - WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- - $ AP( J+K*( 2*N-K-1 ) / 2 ) ) - WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- - $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) + WK = T*( ( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- + $ AP( J+K*( 2*N-K-1 ) / 2 ) ) / D21 ) + WKP1 = T*( ( D22*AP( J+K*( 2*N-K-1 ) / 2 )- + $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) / D21 ) * DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* diff --git a/lapack-netlib/SRC/dsytf2.c b/lapack-netlib/SRC/dsytf2.c index f126f933e9..4a94f4e924 100644 --- a/lapack-netlib/SRC/dsytf2.c +++ b/lapack-netlib/SRC/dsytf2.c @@ -226,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__1 = 1; @@ -240,7 +238,6 @@ oting method (unblocked algorithm). */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download DSYTF2 + dependencies */ /* > */ @@ -251,7 +248,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -361,9 +357,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup doubleSYcomputational */ +/* > \ingroup hetf2 */ /* > \par Further Details: */ /* ===================== */ @@ -434,11 +428,14 @@ f"> */ doublereal d__1, d__2, d__3; /* Local variables */ + integer i__, j, k; + doublereal t, r1, d11, d12, d21, d22; + integer kk, kp; + doublereal wk, wkm1, wkp1; integer imax, jmax; extern /* Subroutine */ void dsyr_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); - integer i__, j, k; - doublereal t, alpha; + doublereal alpha; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); @@ -446,19 +443,16 @@ f"> */ doublereal *, integer *); integer kstep; logical upper; - doublereal r1, d11, d12, d21, d22; - integer kk, kp; - doublereal absakk, wk; + doublereal absakk; extern integer idamax_(integer *, doublereal *, integer *); extern logical disnan_(doublereal *); extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - doublereal colmax, rowmax, wkm1, wkp1; + doublereal colmax, rowmax; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -468,7 +462,7 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; @@ -647,13 +641,12 @@ f"> */ d22 = a[k - 1 + (k - 1) * a_dim1] / d12; d11 = a[k + k * a_dim1] / d12; t = 1. / (d11 * d22 - 1.); - d12 = t / d12; for (j = k - 2; j >= 1; --j) { - wkm1 = d12 * (d11 * a[j + (k - 1) * a_dim1] - a[j + k - * a_dim1]); - wk = d12 * (d22 * a[j + k * a_dim1] - a[j + (k - 1) * - a_dim1]); + wkm1 = t * ((d11 * a[j + (k - 1) * a_dim1] - a[j + k * + a_dim1]) / d12); + wk = t * ((d22 * a[j + k * a_dim1] - a[j + (k - 1) * + a_dim1]) / d12); for (i__ = j; i__ >= 1; --i__) { a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ + k * a_dim1] * wk - a[i__ + (k - 1) * @@ -841,15 +834,14 @@ f"> */ d11 = a[k + 1 + (k + 1) * a_dim1] / d21; d22 = a[k + k * a_dim1] / d21; t = 1. / (d11 * d22 - 1.); - d21 = t / d21; i__1 = *n; for (j = k + 2; j <= i__1; ++j) { - wk = d21 * (d11 * a[j + k * a_dim1] - a[j + (k + 1) * - a_dim1]); - wkp1 = d21 * (d22 * a[j + (k + 1) * a_dim1] - a[j + k - * a_dim1]); + wk = t * ((d11 * a[j + k * a_dim1] - a[j + (k + 1) * + a_dim1]) / d21); + wkp1 = t * ((d22 * a[j + (k + 1) * a_dim1] - a[j + k * + a_dim1]) / d21); i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { diff --git a/lapack-netlib/SRC/dsytf2.f b/lapack-netlib/SRC/dsytf2.f index b05d25ad15..39685c36ad 100644 --- a/lapack-netlib/SRC/dsytf2.f +++ b/lapack-netlib/SRC/dsytf2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DSYTF2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -127,7 +125,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup doubleSYcomputational +*> \ingroup hetf2 * *> \par Further Details: * ===================== @@ -191,6 +189,7 @@ * * ===================================================================== SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -284,7 +283,8 @@ SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) COLMAX = ZERO END IF * - IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. + $ DISNAN(ABSAKK) ) THEN * * Column K is zero or underflow, or contains a NaN: * set INFO and continue @@ -390,11 +390,10 @@ SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = ONE / ( D11*D22-ONE ) - D12 = T / D12 * DO 30 J = K - 2, 1, -1 - WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) ) - WK = D12*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K-1 )*WKM1 @@ -454,7 +453,8 @@ SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) COLMAX = ZERO END IF * - IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. + $ DISNAN(ABSAKK) ) THEN * * Column K is zero or underflow, or contains a NaN: * set INFO and continue @@ -476,7 +476,8 @@ SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA ) ROWMAX = ABS( A( IMAX, JMAX ) ) IF( IMAX.LT.N ) THEN - JMAX = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 ) + JMAX = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) END IF * @@ -508,7 +509,8 @@ SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * submatrix A(k:n,k:n) * IF( KP.LT.N ) - $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), $ LDA ) T = A( KK, KK ) @@ -562,12 +564,11 @@ SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = ONE / ( D11*D22-ONE ) - D21 = T / D21 * DO 60 J = K + 2, N * - WK = D21*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * DO 50 I = J, N A( I, J ) = A( I, J ) - A( I, K )*WK - diff --git a/lapack-netlib/SRC/dsytf2_rk.c b/lapack-netlib/SRC/dsytf2_rk.c index 95b87e08f2..26b1fc25e4 100644 --- a/lapack-netlib/SRC/dsytf2_rk.c +++ b/lapack-netlib/SRC/dsytf2_rk.c @@ -226,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__1 = 1; @@ -240,7 +238,6 @@ nch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm). */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download DSYTF2_RK + dependencies */ /* > */ @@ -251,7 +248,6 @@ rk.f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -442,9 +438,7 @@ rk.f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup doubleSYcomputational */ +/* > \ingroup hetf2_rk */ /* > \par Further Details: */ /* ===================== */ @@ -481,12 +475,15 @@ rk.f"> */ doublereal d__1; /* Local variables */ + integer i__, j, k, p; + doublereal t, d11, d12, d21, d22; + integer ii, kk, kp; + doublereal wk, wkm1, wkp1; logical done; integer imax, jmax; extern /* Subroutine */ void dsyr_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); - integer i__, j, k, p; - doublereal t, alpha; + doublereal alpha; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); @@ -496,20 +493,16 @@ rk.f"> */ doublereal *, integer *); integer kstep; logical upper; - doublereal d11, d12, d21, d22; - integer ii, kk; extern doublereal dlamch_(char *); - integer kp; - doublereal absakk, wk; + doublereal absakk; extern integer idamax_(integer *, doublereal *, integer *); extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - doublereal colmax, rowmax, wkm1, wkp1; + doublereal colmax, rowmax; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -519,7 +512,7 @@ rk.f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --e; --ipiv; @@ -845,22 +838,22 @@ rk.f"> */ for (j = k - 2; j >= 1; --j) { - wkm1 = t * (d11 * a[j + (k - 1) * a_dim1] - a[j + k * - a_dim1]); - wk = t * (d22 * a[j + k * a_dim1] - a[j + (k - 1) * - a_dim1]); + wkm1 = t * ((d11 * a[j + (k - 1) * a_dim1] - a[j + k * + a_dim1]) / d12); + wk = t * ((d22 * a[j + k * a_dim1] - a[j + (k - 1) * + a_dim1]) / d12); for (i__ = j; i__ >= 1; --i__) { a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ - + k * a_dim1] / d12 * wk - a[i__ + (k - 1) - * a_dim1] / d12 * wkm1; + + k * a_dim1] * wk - a[i__ + (k - 1) * + a_dim1] * wkm1; /* L20: */ } /* Store U(k) and U(k-1) in cols k and k-1 for row J */ - a[j + k * a_dim1] = wk / d12; - a[j + (k - 1) * a_dim1] = wkm1 / d12; + a[j + k * a_dim1] = wk; + a[j + (k - 1) * a_dim1] = wkm1; /* L30: */ } @@ -1193,27 +1186,27 @@ rk.f"> */ i__1 = *n; for (j = k + 2; j <= i__1; ++j) { -/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ +/* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J */ - wk = t * (d11 * a[j + k * a_dim1] - a[j + (k + 1) * - a_dim1]); - wkp1 = t * (d22 * a[j + (k + 1) * a_dim1] - a[j + k * - a_dim1]); + wk = t * ((d11 * a[j + k * a_dim1] - a[j + (k + 1) * + a_dim1]) / d21); + wkp1 = t * ((d22 * a[j + (k + 1) * a_dim1] - a[j + k * + a_dim1]) / d21); /* Perform a rank-2 update of A(k+2:n,k+2:n) */ i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ - + k * a_dim1] / d21 * wk - a[i__ + (k + 1) - * a_dim1] / d21 * wkp1; + + k * a_dim1] * wk - a[i__ + (k + 1) * + a_dim1] * wkp1; /* L50: */ } /* Store L(k) and L(k+1) in cols k and k+1 for row J */ - a[j + k * a_dim1] = wk / d21; - a[j + (k + 1) * a_dim1] = wkp1 / d21; + a[j + k * a_dim1] = wk; + a[j + (k + 1) * a_dim1] = wkp1; /* L60: */ } diff --git a/lapack-netlib/SRC/dsytf2_rk.f b/lapack-netlib/SRC/dsytf2_rk.f index e9afcb6aad..1628d9f0ec 100644 --- a/lapack-netlib/SRC/dsytf2_rk.f +++ b/lapack-netlib/SRC/dsytf2_rk.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DSYTF2_RK + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -208,7 +206,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup doubleSYcomputational +*> \ingroup hetf2_rk * *> \par Further Details: * ===================== @@ -238,6 +236,7 @@ * * ===================================================================== SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -460,7 +459,8 @@ SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * the interchanges in columns k+1:N. * IF( K.LT.N ) - $ CALL DSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA ) + $ CALL DSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), + $ LDA ) * END IF * @@ -475,7 +475,8 @@ SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) IF( KP.GT.1 ) $ CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) - $ CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, + $ KP+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) @@ -517,7 +518,8 @@ SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * = A - W(k)*1/D(k)*W(k)**T * D11 = ONE / A( K, K ) - CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) * * Store U(k) in column k * @@ -536,7 +538,8 @@ SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * = A - W(k)*(1/D(k))*W(k)**T * = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T * - CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) END IF * * Store the superdiagonal element of D in array E @@ -570,18 +573,18 @@ SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) - WK = T*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - - $ ( A( I, K-1 ) / D12 )*WKM1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K-1 )*WKM1 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D12 - A( J, K-1 ) = WKM1 / D12 + A( J, K ) = WK + A( J, K-1 ) = WKM1 * 30 CONTINUE * @@ -694,14 +697,16 @@ SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * Determine both ROWMAX and JMAX. * IF( IMAX.NE.K ) THEN - JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA ) + JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), + $ LDA ) ROWMAX = ABS( A( IMAX, JMAX ) ) ELSE ROWMAX = ZERO END IF * IF( IMAX.LT.N ) THEN - ITEMP = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), + ITEMP = IMAX + IDAMAX( N-IMAX, A( IMAX+1, + $ IMAX ), $ 1 ) DTEMP = ABS( A( ITEMP, IMAX ) ) IF( DTEMP.GT.ROWMAX ) THEN @@ -760,7 +765,8 @@ SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) IF( P.LT.N ) $ CALL DSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) IF( P.GT.(K+1) ) - $ CALL DSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + $ CALL DSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), + $ LDA ) T = A( K, K ) A( K, K ) = A( P, P ) A( P, P ) = T @@ -782,9 +788,11 @@ SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * submatrix A(k:n,k:n) * IF( KP.LT.N ) - $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) - $ CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, + $ KK+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) @@ -881,22 +889,22 @@ SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N - A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - - $ ( A( I, K+1 ) / D21 )*WKP1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K+1 )*WKP1 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D21 - A( J, K+1 ) = WKP1 / D21 + A( J, K ) = WK + A( J, K+1 ) = WKP1 * 60 CONTINUE * diff --git a/lapack-netlib/SRC/dsytf2_rook.c b/lapack-netlib/SRC/dsytf2_rook.c index 5f1605145e..0e55e85d67 100644 --- a/lapack-netlib/SRC/dsytf2_rook.c +++ b/lapack-netlib/SRC/dsytf2_rook.c @@ -226,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__1 = 1; @@ -240,7 +238,6 @@ Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm). */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download DSYTF2_ROOK + dependencies */ /* > */ @@ -251,7 +248,6 @@ rook.f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -363,9 +359,7 @@ rook.f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date November 2013 */ - -/* > \ingroup doubleSYcomputational */ +/* > \ingroup hetf2_rook */ /* > \par Further Details: */ /* ===================== */ @@ -434,12 +428,15 @@ rook.f"> */ doublereal d__1; /* Local variables */ + integer i__, j, k, p; + doublereal t, d11, d12, d21, d22; + integer ii, kk, kp; + doublereal wk, wkm1, wkp1; logical done; integer imax, jmax; extern /* Subroutine */ void dsyr_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); - integer i__, j, k, p; - doublereal t, alpha; + doublereal alpha; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); @@ -449,20 +446,16 @@ rook.f"> */ doublereal *, integer *); integer kstep; logical upper; - doublereal d11, d12, d21, d22; - integer ii, kk; extern doublereal dlamch_(char *); - integer kp; - doublereal absakk, wk; + doublereal absakk; extern integer idamax_(integer *, doublereal *, integer *); extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - doublereal colmax, rowmax, wkm1, wkp1; + doublereal colmax, rowmax; -/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* November 2013 */ /* ===================================================================== */ @@ -472,7 +465,7 @@ rook.f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; @@ -760,22 +753,22 @@ rook.f"> */ for (j = k - 2; j >= 1; --j) { - wkm1 = t * (d11 * a[j + (k - 1) * a_dim1] - a[j + k * - a_dim1]); - wk = t * (d22 * a[j + k * a_dim1] - a[j + (k - 1) * - a_dim1]); + wkm1 = t * ((d11 * a[j + (k - 1) * a_dim1] - a[j + k * + a_dim1]) / d12); + wk = t * ((d22 * a[j + k * a_dim1] - a[j + (k - 1) * + a_dim1]) / d12); for (i__ = j; i__ >= 1; --i__) { a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ - + k * a_dim1] / d12 * wk - a[i__ + (k - 1) - * a_dim1] / d12 * wkm1; + + k * a_dim1] * wk - a[i__ + (k - 1) * + a_dim1] * wkm1; /* L20: */ } /* Store U(k) and U(k-1) in cols k and k-1 for row J */ - a[j + k * a_dim1] = wk / d12; - a[j + (k - 1) * a_dim1] = wkm1 / d12; + a[j + k * a_dim1] = wk; + a[j + (k - 1) * a_dim1] = wkm1; /* L30: */ } @@ -1060,27 +1053,27 @@ rook.f"> */ i__1 = *n; for (j = k + 2; j <= i__1; ++j) { -/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ +/* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J */ - wk = t * (d11 * a[j + k * a_dim1] - a[j + (k + 1) * - a_dim1]); - wkp1 = t * (d22 * a[j + (k + 1) * a_dim1] - a[j + k * - a_dim1]); + wk = t * ((d11 * a[j + k * a_dim1] - a[j + (k + 1) * + a_dim1]) / d21); + wkp1 = t * ((d22 * a[j + (k + 1) * a_dim1] - a[j + k * + a_dim1]) / d21); /* Perform a rank-2 update of A(k+2:n,k+2:n) */ i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ - + k * a_dim1] / d21 * wk - a[i__ + (k + 1) - * a_dim1] / d21 * wkp1; + + k * a_dim1] * wk - a[i__ + (k + 1) * + a_dim1] * wkp1; /* L50: */ } /* Store L(k) and L(k+1) in cols k and k+1 for row J */ - a[j + k * a_dim1] = wk / d21; - a[j + (k + 1) * a_dim1] = wkp1 / d21; + a[j + k * a_dim1] = wk; + a[j + (k + 1) * a_dim1] = wkp1; /* L60: */ } diff --git a/lapack-netlib/SRC/dsytf2_rook.f b/lapack-netlib/SRC/dsytf2_rook.f index 251b3909bb..e5935aec7a 100644 --- a/lapack-netlib/SRC/dsytf2_rook.f +++ b/lapack-netlib/SRC/dsytf2_rook.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DSYTF2_ROOK + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -129,7 +127,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup doubleSYcomputational +*> \ingroup hetf2_rook * *> \par Further Details: * ===================== @@ -191,6 +189,7 @@ * * ===================================================================== SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -410,7 +409,8 @@ SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) IF( KP.GT.1 ) $ CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) - $ CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, + $ KP+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) @@ -444,7 +444,8 @@ SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * = A - W(k)*1/D(k)*W(k)**T * D11 = ONE / A( K, K ) - CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) * * Store U(k) in column k * @@ -463,7 +464,8 @@ SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * = A - W(k)*(1/D(k))*W(k)**T * = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T * - CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) END IF END IF * @@ -492,18 +494,18 @@ SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) - WK = T*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - - $ ( A( I, K-1 ) / D12 )*WKM1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K-1 )*WKM1 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D12 - A( J, K-1 ) = WKM1 / D12 + A( J, K ) = WK + A( J, K-1 ) = WKM1 * 30 CONTINUE * @@ -593,14 +595,16 @@ SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * Determine both ROWMAX and JMAX. * IF( IMAX.NE.K ) THEN - JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA ) + JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), + $ LDA ) ROWMAX = ABS( A( IMAX, JMAX ) ) ELSE ROWMAX = ZERO END IF * IF( IMAX.LT.N ) THEN - ITEMP = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), + ITEMP = IMAX + IDAMAX( N-IMAX, A( IMAX+1, + $ IMAX ), $ 1 ) DTEMP = ABS( A( ITEMP, IMAX ) ) IF( DTEMP.GT.ROWMAX ) THEN @@ -659,7 +663,8 @@ SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) IF( P.LT.N ) $ CALL DSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) IF( P.GT.(K+1) ) - $ CALL DSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + $ CALL DSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), + $ LDA ) T = A( K, K ) A( K, K ) = A( P, P ) A( P, P ) = T @@ -674,9 +679,11 @@ SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * submatrix A(k:n,k:n) * IF( KP.LT.N ) - $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) - $ CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, + $ KK+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) @@ -761,22 +768,22 @@ SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N - A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - - $ ( A( I, K+1 ) / D21 )*WKP1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K+1 )*WKP1 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D21 - A( J, K+1 ) = WKP1 / D21 + A( J, K ) = WK + A( J, K+1 ) = WKP1 * 60 CONTINUE * diff --git a/lapack-netlib/SRC/slasyf.c b/lapack-netlib/SRC/slasyf.c index 06401404a7..1ea92fb74b 100644 --- a/lapack-netlib/SRC/slasyf.c +++ b/lapack-netlib/SRC/slasyf.c @@ -220,258 +220,6 @@ typedef struct Namelist Namelist; //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} -/* procedure parameter types for -A and -C++ */ - - -#ifdef __cplusplus -typedef logical (*L_fp)(...); -#else -typedef logical (*L_fp)(); -#endif -#if 0 -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#ifdef _MSC_VER -static _Fcomplex cpow_ui(complex x, integer n) { - complex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; - for(u = n; ; ) { - if(u & 01) pow.r *= x.r, pow.i *= x.i; - if(u >>= 1) x.r *= x.r, x.i *= x.i; - else break; - } - } - _Fcomplex p={pow.r, pow.i}; - return p; -} -#else -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -#ifdef _MSC_VER -static _Dcomplex zpow_ui(_Dcomplex x, integer n) { - _Dcomplex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; - for(u = n; ; ) { - if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; - if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; - else break; - } - } - _Dcomplex p = {pow._Val[0], pow._Val[1]}; - return p; -} -#else -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; - } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; -#ifdef _MSC_VER - _Fcomplex zdotc = {0.0, 0.0}; - if (incx == 1 && incy == 1) { - for (i=0;i \htmlonly */ /* > Download SLASYF + dependencies */ /* > */ @@ -498,7 +245,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -640,9 +386,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date November 2013 */ - -/* > \ingroup realSYcomputational */ +/* > \ingroup lahef */ /* > \par Contributors: */ /* ================== */ @@ -660,34 +404,33 @@ f"> */ *info) { /* System generated locals */ - integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2; real r__1, r__2, r__3; /* Local variables */ - integer imax, jmax, j, k; - real t, alpha; + integer j, k; + real t, r1, d11, d21, d22; + integer jj, kk, jp, kp, kw, kkw, imax, jmax; + real alpha; extern logical lsame_(char *, char *); extern /* Subroutine */ void sscal_(integer *, real *, real *, integer *), - sgemm_(char *, char *, integer *, integer *, integer *, real *, - real *, integer *, real *, integer *, real *, real *, integer *), sgemv_(char *, integer *, integer *, real *, - real *, integer *, real *, integer *, real *, real *, integer *); + sgemv_(char *, integer *, integer *, real *, real *, integer *, + real *, integer *, real *, real *, integer *); integer kstep; extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, integer *), sswap_(integer *, real *, integer *, real *, integer * ); - real r1, d11, d21, d22; - integer jb, jj, kk, jp, kp; real absakk; - integer kw; extern integer isamax_(integer *, real *, integer *); real colmax, rowmax; - integer kkw; + extern /* Subroutine */ void sgemmtr_(char *, char *, char *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); -/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* November 2013 */ /* ===================================================================== */ @@ -695,11 +438,11 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; w_dim1 = *ldw; - w_offset = 1 + w_dim1 * 1; + w_offset = 1 + w_dim1; w -= w_offset; /* Function Body */ @@ -725,7 +468,7 @@ f"> */ /* Exit from loop */ - if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { goto L30; } @@ -766,6 +509,7 @@ f"> */ *info = k; } kp = k; + scopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); } else { if (absakk >= alpha * colmax) { @@ -938,14 +682,14 @@ f"> */ /* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */ /* ( ( -1 ) ( D22 ) ) */ -/* = D21 * ( ( D11 ) ( -1 ) ) */ -/* ( ( -1 ) ( D22 ) ) */ +/* T/d21 is not formed, since it overflows when d21 is */ +/* subnormal: each entry of the product is divided by */ +/* d21 and then scaled by T. */ d21 = w[k - 1 + kw * w_dim1]; d11 = w[k + kw * w_dim1] / d21; d22 = w[k - 1 + (kw - 1) * w_dim1] / d21; t = 1.f / (d11 * d22 - 1.f); - d21 = t / d21; /* Update elements in columns A(k-1) and A(k) as */ /* dot products of rows of ( W(kw-1) W(kw) ) and columns */ @@ -953,10 +697,10 @@ f"> */ i__1 = k - 2; for (j = 1; j <= i__1; ++j) { - a[j + (k - 1) * a_dim1] = d21 * (d11 * w[j + (kw - 1) - * w_dim1] - w[j + kw * w_dim1]); - a[j + k * a_dim1] = d21 * (d22 * w[j + kw * w_dim1] - - w[j + (kw - 1) * w_dim1]); + a[j + (k - 1) * a_dim1] = t * ((d11 * w[j + (kw - 1) * + w_dim1] - w[j + kw * w_dim1]) / d21); + a[j + k * a_dim1] = t * ((d22 * w[j + kw * w_dim1] - + w[j + (kw - 1) * w_dim1]) / d21); /* L20: */ } } @@ -991,36 +735,10 @@ f"> */ /* A11 := A11 - U12*D*U12**T = A11 - U12*W**T */ -/* computing blocks of NB columns at a time */ - - i__1 = -(*nb); - for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += - i__1) { -/* Computing MIN */ - i__2 = *nb, i__3 = k - j + 1; - jb = f2cmin(i__2,i__3); - -/* Update the upper triangle of the diagonal block */ - - i__2 = j + jb - 1; - for (jj = j; jj <= i__2; ++jj) { - i__3 = jj - j + 1; - i__4 = *n - k; - sgemv_("No transpose", &i__3, &i__4, &c_b8, &a[j + (k + 1) * - a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b9, - &a[j + jj * a_dim1], &c__1); -/* L40: */ - } - -/* Update the rectangular superdiagonal block */ - - i__2 = j - 1; - i__3 = *n - k; - sgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &c_b8, &a[( - k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw, - &c_b9, &a[j * a_dim1 + 1], lda); -/* L50: */ - } + i__1 = *n - k; + sgemmtr_("Upper", "No transpose", "Transpose", &k, &i__1, &c_b8, &a[( + k + 1) * a_dim1 + 1], lda, &w[(kw + 1) * w_dim1 + 1], ldw, & + c_b9, &a[a_dim1 + 1], lda); /* Put U12 in standard form by partially undoing the interchanges */ /* in columns k+1:n looping backwards from k+1 to n */ @@ -1067,7 +785,7 @@ f"> */ /* Exit from loop */ - if ((k >= *nb && *nb < *n) || k > *n) { + if (k >= *nb && *nb < *n || k > *n) { goto L90; } @@ -1107,6 +825,9 @@ f"> */ *info = k; } kp = k; + i__1 = *n - k + 1; + scopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); } else { if (absakk >= alpha * colmax) { @@ -1277,14 +998,14 @@ f"> */ /* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */ /* ( ( -1 ) ( D22 ) ) */ -/* = D21 * ( ( D11 ) ( -1 ) ) */ -/* ( ( -1 ) ( D22 ) ) */ +/* T/d21 is not formed, since it overflows when d21 is */ +/* subnormal: each entry of the product is divided by */ +/* d21 and then scaled by T. */ d21 = w[k + 1 + k * w_dim1]; d11 = w[k + 1 + (k + 1) * w_dim1] / d21; d22 = w[k + k * w_dim1] / d21; t = 1.f / (d11 * d22 - 1.f); - d21 = t / d21; /* Update elements in columns A(k) and A(k+1) as */ /* dot products of rows of ( W(k) W(k+1) ) and columns */ @@ -1292,10 +1013,10 @@ f"> */ i__1 = *n; for (j = k + 2; j <= i__1; ++j) { - a[j + k * a_dim1] = d21 * (d11 * w[j + k * w_dim1] - - w[j + (k + 1) * w_dim1]); - a[j + (k + 1) * a_dim1] = d21 * (d22 * w[j + (k + 1) * - w_dim1] - w[j + k * w_dim1]); + a[j + k * a_dim1] = t * ((d11 * w[j + k * w_dim1] - w[ + j + (k + 1) * w_dim1]) / d21); + a[j + (k + 1) * a_dim1] = t * ((d22 * w[j + (k + 1) * + w_dim1] - w[j + k * w_dim1]) / d21); /* L80: */ } } @@ -1330,38 +1051,11 @@ f"> */ /* A22 := A22 - L21*D*L21**T = A22 - L21*W**T */ -/* computing blocks of NB columns at a time */ - - i__1 = *n; - i__2 = *nb; - for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { -/* Computing MIN */ - i__3 = *nb, i__4 = *n - j + 1; - jb = f2cmin(i__3,i__4); - -/* Update the lower triangle of the diagonal block */ - - i__3 = j + jb - 1; - for (jj = j; jj <= i__3; ++jj) { - i__4 = j + jb - jj; - i__5 = k - 1; - sgemv_("No transpose", &i__4, &i__5, &c_b8, &a[jj + a_dim1], - lda, &w[jj + w_dim1], ldw, &c_b9, &a[jj + jj * a_dim1] - , &c__1); -/* L100: */ - } - -/* Update the rectangular subdiagonal block */ - - if (j + jb <= *n) { - i__3 = *n - j - jb + 1; - i__4 = k - 1; - sgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &c_b8, - &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b9, - &a[j + jb + j * a_dim1], lda); - } -/* L110: */ - } + i__1 = *n - k + 1; + i__2 = k - 1; + sgemmtr_("Lower", "No transpose", "Transpose", &i__1, &i__2, &c_b8, & + a[k + a_dim1], lda, &w[k + w_dim1], ldw, &c_b9, &a[k + k * + a_dim1], lda); /* Put L21 in standard form by partially undoing the interchanges */ /* of rows in columns 1:k-1 looping backwards from k-1 to 1 */ diff --git a/lapack-netlib/SRC/slasyf.f b/lapack-netlib/SRC/slasyf.f index c551c1460f..1bac75a627 100644 --- a/lapack-netlib/SRC/slasyf.f +++ b/lapack-netlib/SRC/slasyf.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SLASYF + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -159,7 +157,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realSYcomputational +*> \ingroup lahef * *> \par Contributors: * ================== @@ -172,7 +170,9 @@ *> \endverbatim * * ===================================================================== - SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) + SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, + $ INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -196,7 +196,7 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) * .. * .. Local Scalars .. - INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP, + INTEGER IMAX, J, JJ, JMAX, JP, K, KK, KKW, KP, $ KSTEP, KW REAL ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1, $ ROWMAX, T @@ -207,7 +207,7 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) EXTERNAL LSAME, ISAMAX * .. * .. External Subroutines .. - EXTERNAL SCOPY, SGEMM, SGEMV, SSCAL, SSWAP + EXTERNAL SCOPY, SGEMMTR, SGEMV, SSCAL, SSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT @@ -243,7 +243,8 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * CALL SCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) IF( K.LT.N ) - $ CALL SGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), LDA, + $ CALL SGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), + $ LDA, $ W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 ) * KSTEP = 1 @@ -271,6 +272,7 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL SCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * @@ -285,7 +287,8 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) CALL SCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, $ W( IMAX+1, KW-1 ), 1 ) IF( K.LT.N ) - $ CALL SGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), + $ CALL SGEMV( 'No transpose', K, N-K, -ONE, A( 1, + $ K+1 ), $ LDA, W( IMAX, KW+1 ), LDW, ONE, $ W( 1, KW-1 ), 1 ) * @@ -422,22 +425,24 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* = D21 * ( ( D11 ) ( -1 ) ) -* ( ( -1 ) ( D22 ) ) +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 D22 = W( K-1, KW-1 ) / D21 T = ONE / ( D11*D22-ONE ) - D21 = T / D21 * * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) * DO 20 J = 1, K - 2 - A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) - A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D21 ) 20 CONTINUE END IF * @@ -471,25 +476,9 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * A11 := A11 - U12*D*U12**T = A11 - U12*W**T * -* computing blocks of NB columns at a time -* - DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB - JB = MIN( NB, K-J+1 ) -* -* Update the upper triangle of the diagonal block -* - DO 40 JJ = J, J + JB - 1 - CALL SGEMV( 'No transpose', JJ-J+1, N-K, -ONE, - $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, - $ A( J, JJ ), 1 ) - 40 CONTINUE -* -* Update the rectangular superdiagonal block -* - CALL SGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, -ONE, - $ A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE, - $ A( 1, J ), LDA ) - 50 CONTINUE + CALL SGEMMTR( 'Upper', 'No transpose', 'Transpose', K, N-K, + $ -ONE, A( 1, K+1 ), LDA, W( 1, KW+1 ), LDW, + $ ONE, A( 1, 1 ), LDA ) * * Put U12 in standard form by partially undoing the interchanges * in columns k+1:n looping backwards from k+1 to n @@ -539,7 +528,8 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * Copy column K of A to column K of W and update it * CALL SCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) - CALL SGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), LDA, + CALL SGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), + $ LDA, $ W( K, 1 ), LDW, ONE, W( K, K ), 1 ) * KSTEP = 1 @@ -567,6 +557,7 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL SCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * @@ -577,10 +568,13 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * Copy column IMAX to column K+1 of W and update it * - CALL SCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 ) - CALL SCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ), + CALL SCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), + $ 1 ) + CALL SCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, + $ K+1 ), $ 1 ) - CALL SGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), + CALL SGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, + $ 1 ), $ LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 ) * * JMAX is the column-index of the largest off-diagonal @@ -638,7 +632,8 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) CALL SCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), $ LDA ) IF( KP.LT.N ) - $ CALL SCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL SCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) * * Interchange rows KK and KP in first K-1 columns of A * (columns K (or K and K+1 for 2-by-2 pivot) of A will be @@ -712,22 +707,24 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* = D21 * ( ( D11 ) ( -1 ) ) -* ( ( -1 ) ( D22 ) ) +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = ONE / ( D11*D22-ONE ) - D21 = T / D21 * * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) * DO 80 J = K + 2, N - A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) - A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * @@ -761,26 +758,9 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * A22 := A22 - L21*D*L21**T = A22 - L21*W**T * -* computing blocks of NB columns at a time -* - DO 110 J = K, N, NB - JB = MIN( NB, N-J+1 ) -* -* Update the lower triangle of the diagonal block -* - DO 100 JJ = J, J + JB - 1 - CALL SGEMV( 'No transpose', J+JB-JJ, K-1, -ONE, - $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, - $ A( JJ, JJ ), 1 ) - 100 CONTINUE -* -* Update the rectangular subdiagonal block -* - IF( J+JB.LE.N ) - $ CALL SGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, - $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW, - $ ONE, A( J+JB, J ), LDA ) - 110 CONTINUE + CALL SGEMMTR( 'Lower', 'No transpose', 'Transpose', N-K+1, + $ K-1, -ONE, A( K, 1 ), LDA, W( K, 1 ), LDW, + $ ONE, A( K, K ), LDA ) * * Put L21 in standard form by partially undoing the interchanges * of rows in columns 1:k-1 looping backwards from k-1 to 1 diff --git a/lapack-netlib/SRC/ssptrf.c b/lapack-netlib/SRC/ssptrf.c index 17d9c91229..657c365a7b 100644 --- a/lapack-netlib/SRC/ssptrf.c +++ b/lapack-netlib/SRC/ssptrf.c @@ -220,258 +220,6 @@ typedef struct Namelist Namelist; //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} -/* procedure parameter types for -A and -C++ */ - - -#ifdef __cplusplus -typedef logical (*L_fp)(...); -#else -typedef logical (*L_fp)(); -#endif -#if 0 -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#ifdef _MSC_VER -static _Fcomplex cpow_ui(complex x, integer n) { - complex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; - for(u = n; ; ) { - if(u & 01) pow.r *= x.r, pow.i *= x.i; - if(u >>= 1) x.r *= x.r, x.i *= x.i; - else break; - } - } - _Fcomplex p={pow.r, pow.i}; - return p; -} -#else -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -#ifdef _MSC_VER -static _Dcomplex zpow_ui(_Dcomplex x, integer n) { - _Dcomplex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; - for(u = n; ; ) { - if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; - if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; - else break; - } - } - _Dcomplex p = {pow._Val[0], pow._Val[1]}; - return p; -} -#else -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; - } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; -#ifdef _MSC_VER - _Fcomplex zdotc = {0.0, 0.0}; - if (incx == 1 && incy == 1) { - for (i=0;i \htmlonly */ /* > Download SSPTRF + dependencies */ /* > */ @@ -495,7 +242,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -585,9 +331,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup realOTHERcomputational */ +/* > \ingroup hptrf */ /* > \par Further Details: */ /* ===================== */ @@ -641,32 +385,33 @@ f"> */ real r__1, r__2, r__3; /* Local variables */ + integer i__, j, k; + real t, r1, d11, d12, d21, d22; + integer kc, kk, kp; + real wk; + integer kx, knc, kpc, npp; + real wkm1, wkp1; integer imax, jmax; extern /* Subroutine */ void sspr_(char *, integer *, real *, real *, integer *, real *); - integer i__, j, k; - real t, alpha; + real alpha; extern logical lsame_(char *, char *); extern /* Subroutine */ void sscal_(integer *, real *, real *, integer *); integer kstep; logical upper; extern /* Subroutine */ void sswap_(integer *, real *, integer *, real *, integer *); - real r1, d11, d12, d21, d22; - integer kc, kk, kp; - real absakk, wk; - integer kx; + real absakk; extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); extern integer isamax_(integer *, real *, integer *); - real colmax, rowmax; - integer knc, kpc, npp; - real wkm1, wkp1; + real colmax; + extern logical sisnan_(real *); + real rowmax; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -731,9 +476,10 @@ f"> */ colmax = 0.f; } - if (f2cmax(absakk,colmax) == 0.f) { + if (f2cmax(absakk,colmax) == 0.f || sisnan_(&absakk)) { -/* Column K is zero: set INFO and continue */ +/* Column K is zero or underflow, or contains a NaN: */ +/* set INFO and continue */ if (*info == 0) { *info = k; @@ -864,13 +610,12 @@ f"> */ d22 = ap[k - 1 + (k - 2) * (k - 1) / 2] / d12; d11 = ap[k + (k - 1) * k / 2] / d12; t = 1.f / (d11 * d22 - 1.f); - d12 = t / d12; for (j = k - 2; j >= 1; --j) { - wkm1 = d12 * (d11 * ap[j + (k - 2) * (k - 1) / 2] - - ap[j + (k - 1) * k / 2]); - wk = d12 * (d22 * ap[j + (k - 1) * k / 2] - ap[j + (k - - 2) * (k - 1) / 2]); + wkm1 = t * ((d11 * ap[j + (k - 2) * (k - 1) / 2] - ap[ + j + (k - 1) * k / 2]) / d12); + wk = t * ((d22 * ap[j + (k - 1) * k / 2] - ap[j + (k + - 2) * (k - 1) / 2]) / d12); for (i__ = j; i__ >= 1; --i__) { ap[i__ + (j - 1) * j / 2] = ap[i__ + (j - 1) * j / 2] - ap[i__ + (k - 1) * k / 2] * wk - ap[ @@ -938,9 +683,10 @@ f"> */ colmax = 0.f; } - if (f2cmax(absakk,colmax) == 0.f) { + if (f2cmax(absakk,colmax) == 0.f || sisnan_(&absakk)) { -/* Column K is zero: set INFO and continue */ +/* Column K is zero or underflow, or contains a NaN: */ +/* set INFO and continue */ if (*info == 0) { *info = k; @@ -1082,14 +828,15 @@ f"> */ d11 = ap[k + 1 + k * ((*n << 1) - k - 1) / 2] / d21; d22 = ap[k + (k - 1) * ((*n << 1) - k) / 2] / d21; t = 1.f / (d11 * d22 - 1.f); - d21 = t / d21; i__1 = *n; for (j = k + 2; j <= i__1; ++j) { - wk = d21 * (d11 * ap[j + (k - 1) * ((*n << 1) - k) / - 2] - ap[j + k * ((*n << 1) - k - 1) / 2]); - wkp1 = d21 * (d22 * ap[j + k * ((*n << 1) - k - 1) / - 2] - ap[j + (k - 1) * ((*n << 1) - k) / 2]); + wk = t * ((d11 * ap[j + (k - 1) * ((*n << 1) - k) / 2] + - ap[j + k * ((*n << 1) - k - 1) / 2]) / d21) + ; + wkp1 = t * ((d22 * ap[j + k * ((*n << 1) - k - 1) / 2] + - ap[j + (k - 1) * ((*n << 1) - k) / 2]) / + d21); i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { diff --git a/lapack-netlib/SRC/ssptrf.f b/lapack-netlib/SRC/ssptrf.f index 3c4456a148..dd54eb1f55 100644 --- a/lapack-netlib/SRC/ssptrf.f +++ b/lapack-netlib/SRC/ssptrf.f @@ -366,13 +366,12 @@ SUBROUTINE SSPTRF( UPLO, N, AP, IPIV, INFO ) D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12 D11 = AP( K+( K-1 )*K / 2 ) / D12 T = ONE / ( D11*D22-ONE ) - D12 = T / D12 * DO 50 J = K - 2, 1, -1 - WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ AP( J+( K-1 )*K / 2 ) ) - WK = D12*( D22*AP( J+( K-1 )*K / 2 )- - $ AP( J+( K-2 )*( K-1 ) / 2 ) ) + WKM1 = T*( ( D11*AP( J+( K-2 )*( K-1 ) / 2 )- + $ AP( J+( K-1 )*K / 2 ) ) / D12 ) + WK = T*( ( D22*AP( J+( K-1 )*K / 2 )- + $ AP( J+( K-2 )*( K-1 ) / 2 ) ) / D12 ) DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*WK - @@ -568,13 +567,12 @@ SUBROUTINE SSPTRF( UPLO, N, AP, IPIV, INFO ) D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 T = ONE / ( D11*D22-ONE ) - D21 = T / D21 * DO 100 J = K + 2, N - WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- - $ AP( J+K*( 2*N-K-1 ) / 2 ) ) - WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- - $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) + WK = T*( ( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- + $ AP( J+K*( 2*N-K-1 ) / 2 ) ) / D21 ) + WKP1 = T*( ( D22*AP( J+K*( 2*N-K-1 ) / 2 )- + $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) / D21 ) * DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* diff --git a/lapack-netlib/SRC/ssytf2.c b/lapack-netlib/SRC/ssytf2.c index 2fd4d5276e..b7d22e150e 100644 --- a/lapack-netlib/SRC/ssytf2.c +++ b/lapack-netlib/SRC/ssytf2.c @@ -220,258 +220,6 @@ typedef struct Namelist Namelist; //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} -/* procedure parameter types for -A and -C++ */ - - -#ifdef __cplusplus -typedef logical (*L_fp)(...); -#else -typedef logical (*L_fp)(); -#endif -#if 0 -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#ifdef _MSC_VER -static _Fcomplex cpow_ui(complex x, integer n) { - complex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; - for(u = n; ; ) { - if(u & 01) pow.r *= x.r, pow.i *= x.i; - if(u >>= 1) x.r *= x.r, x.i *= x.i; - else break; - } - } - _Fcomplex p={pow.r, pow.i}; - return p; -} -#else -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -#ifdef _MSC_VER -static _Dcomplex zpow_ui(_Dcomplex x, integer n) { - _Dcomplex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; - for(u = n; ; ) { - if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; - if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; - else break; - } - } - _Dcomplex p = {pow._Val[0], pow._Val[1]}; - return p; -} -#else -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; - } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; -#ifdef _MSC_VER - _Fcomplex zdotc = {0.0, 0.0}; - if (incx == 1 && incy == 1) { - for (i=0;i \htmlonly */ /* > Download SSYTF2 + dependencies */ /* > */ @@ -496,7 +243,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -606,9 +352,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup realSYcomputational */ +/* > \ingroup hetf2 */ /* > \par Further Details: */ /* ===================== */ @@ -680,31 +424,31 @@ f"> */ real r__1, r__2, r__3; /* Local variables */ + integer i__, j, k; + real t, r1, d11, d12, d21, d22; + integer kk, kp; + real wk, wkm1, wkp1; integer imax, jmax; extern /* Subroutine */ void ssyr_(char *, integer *, real *, real *, integer *, real *, integer *); - integer i__, j, k; - real t, alpha; + real alpha; extern logical lsame_(char *, char *); extern /* Subroutine */ void sscal_(integer *, real *, real *, integer *); integer kstep; logical upper; extern /* Subroutine */ void sswap_(integer *, real *, integer *, real *, integer *); - real r1, d11, d12, d21, d22; - integer kk, kp; - real absakk, wk; + real absakk; extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); extern integer isamax_(integer *, real *, integer *); real colmax; extern logical sisnan_(real *); - real rowmax, wkm1, wkp1; + real rowmax; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -714,7 +458,7 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; @@ -893,13 +637,12 @@ f"> */ d22 = a[k - 1 + (k - 1) * a_dim1] / d12; d11 = a[k + k * a_dim1] / d12; t = 1.f / (d11 * d22 - 1.f); - d12 = t / d12; for (j = k - 2; j >= 1; --j) { - wkm1 = d12 * (d11 * a[j + (k - 1) * a_dim1] - a[j + k - * a_dim1]); - wk = d12 * (d22 * a[j + k * a_dim1] - a[j + (k - 1) * - a_dim1]); + wkm1 = t * ((d11 * a[j + (k - 1) * a_dim1] - a[j + k * + a_dim1]) / d12); + wk = t * ((d22 * a[j + k * a_dim1] - a[j + (k - 1) * + a_dim1]) / d12); for (i__ = j; i__ >= 1; --i__) { a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ + k * a_dim1] * wk - a[i__ + (k - 1) * @@ -1087,15 +830,14 @@ f"> */ d11 = a[k + 1 + (k + 1) * a_dim1] / d21; d22 = a[k + k * a_dim1] / d21; t = 1.f / (d11 * d22 - 1.f); - d21 = t / d21; i__1 = *n; for (j = k + 2; j <= i__1; ++j) { - wk = d21 * (d11 * a[j + k * a_dim1] - a[j + (k + 1) * - a_dim1]); - wkp1 = d21 * (d22 * a[j + (k + 1) * a_dim1] - a[j + k - * a_dim1]); + wk = t * ((d11 * a[j + k * a_dim1] - a[j + (k + 1) * + a_dim1]) / d21); + wkp1 = t * ((d22 * a[j + (k + 1) * a_dim1] - a[j + k * + a_dim1]) / d21); i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { diff --git a/lapack-netlib/SRC/ssytf2.f b/lapack-netlib/SRC/ssytf2.f index 1e8087996d..739852112f 100644 --- a/lapack-netlib/SRC/ssytf2.f +++ b/lapack-netlib/SRC/ssytf2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SSYTF2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -127,7 +125,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realSYcomputational +*> \ingroup hetf2 * *> \par Further Details: * ===================== @@ -192,6 +190,7 @@ * * ===================================================================== SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -285,7 +284,8 @@ SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO ) COLMAX = ZERO END IF * - IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. + $ SISNAN(ABSAKK) ) THEN * * Column K is zero or underflow, or contains a NaN: * set INFO and continue @@ -391,11 +391,10 @@ SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = ONE / ( D11*D22-ONE ) - D12 = T / D12 * DO 30 J = K - 2, 1, -1 - WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) ) - WK = D12*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K-1 )*WKM1 @@ -455,7 +454,8 @@ SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO ) COLMAX = ZERO END IF * - IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. + $ SISNAN(ABSAKK) ) THEN * * Column K is zero or underflow, or contains a NaN: * set INFO and continue @@ -477,7 +477,8 @@ SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO ) JMAX = K - 1 + ISAMAX( IMAX-K, A( IMAX, K ), LDA ) ROWMAX = ABS( A( IMAX, JMAX ) ) IF( IMAX.LT.N ) THEN - JMAX = IMAX + ISAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 ) + JMAX = IMAX + ISAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) END IF * @@ -509,7 +510,8 @@ SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * submatrix A(k:n,k:n) * IF( KP.LT.N ) - $ CALL SSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL SSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) CALL SSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), $ LDA ) T = A( KK, KK ) @@ -563,12 +565,11 @@ SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = ONE / ( D11*D22-ONE ) - D21 = T / D21 * DO 60 J = K + 2, N * - WK = D21*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * DO 50 I = J, N A( I, J ) = A( I, J ) - A( I, K )*WK - diff --git a/lapack-netlib/SRC/ssytf2_rk.c b/lapack-netlib/SRC/ssytf2_rk.c index 3c2f44ad52..a11a6d688c 100644 --- a/lapack-netlib/SRC/ssytf2_rk.c +++ b/lapack-netlib/SRC/ssytf2_rk.c @@ -220,258 +220,6 @@ typedef struct Namelist Namelist; //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} -/* procedure parameter types for -A and -C++ */ - - -#ifdef __cplusplus -typedef logical (*L_fp)(...); -#else -typedef logical (*L_fp)(); -#endif -#if 0 -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#ifdef _MSC_VER -static _Fcomplex cpow_ui(complex x, integer n) { - complex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; - for(u = n; ; ) { - if(u & 01) pow.r *= x.r, pow.i *= x.i; - if(u >>= 1) x.r *= x.r, x.i *= x.i; - else break; - } - } - _Fcomplex p={pow.r, pow.i}; - return p; -} -#else -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -#ifdef _MSC_VER -static _Dcomplex zpow_ui(_Dcomplex x, integer n) { - _Dcomplex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; - for(u = n; ; ) { - if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; - if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; - else break; - } - } - _Dcomplex p = {pow._Val[0], pow._Val[1]}; - return p; -} -#else -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; - } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; -#ifdef _MSC_VER - _Fcomplex zdotc = {0.0, 0.0}; - if (incx == 1 && incy == 1) { - for (i=0;i \htmlonly */ /* > Download SSYTF2_RK + dependencies */ /* > */ @@ -496,7 +243,6 @@ rk.f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -687,9 +433,7 @@ rk.f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup singleSYcomputational */ +/* > \ingroup hetf2_rk */ /* > \par Further Details: */ /* ===================== */ @@ -726,12 +470,15 @@ rk.f"> */ real r__1; /* Local variables */ + integer i__, j, k, p; + real t, d11, d12, d21, d22; + integer ii, kk, kp; + real wk, wkm1, wkp1; logical done; integer imax, jmax; extern /* Subroutine */ void ssyr_(char *, integer *, real *, real *, integer *, real *, integer *); - integer i__, j, k, p; - real t, alpha; + real alpha; extern logical lsame_(char *, char *); extern /* Subroutine */ void sscal_(integer *, real *, real *, integer *); real sfmin; @@ -740,19 +487,16 @@ rk.f"> */ logical upper; extern /* Subroutine */ void sswap_(integer *, real *, integer *, real *, integer *); - real d11, d12, d21, d22; - integer ii, kk, kp; - real absakk, wk; + real absakk; extern real slamch_(char *); extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); extern integer isamax_(integer *, real *, integer *); - real colmax, rowmax, wkm1, wkp1; + real colmax, rowmax; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -762,7 +506,7 @@ rk.f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --e; --ipiv; @@ -1088,22 +832,22 @@ rk.f"> */ for (j = k - 2; j >= 1; --j) { - wkm1 = t * (d11 * a[j + (k - 1) * a_dim1] - a[j + k * - a_dim1]); - wk = t * (d22 * a[j + k * a_dim1] - a[j + (k - 1) * - a_dim1]); + wkm1 = t * ((d11 * a[j + (k - 1) * a_dim1] - a[j + k * + a_dim1]) / d12); + wk = t * ((d22 * a[j + k * a_dim1] - a[j + (k - 1) * + a_dim1]) / d12); for (i__ = j; i__ >= 1; --i__) { a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ - + k * a_dim1] / d12 * wk - a[i__ + (k - 1) - * a_dim1] / d12 * wkm1; + + k * a_dim1] * wk - a[i__ + (k - 1) * + a_dim1] * wkm1; /* L20: */ } /* Store U(k) and U(k-1) in cols k and k-1 for row J */ - a[j + k * a_dim1] = wk / d12; - a[j + (k - 1) * a_dim1] = wkm1 / d12; + a[j + k * a_dim1] = wk; + a[j + (k - 1) * a_dim1] = wkm1; /* L30: */ } @@ -1436,27 +1180,27 @@ rk.f"> */ i__1 = *n; for (j = k + 2; j <= i__1; ++j) { -/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ +/* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J */ - wk = t * (d11 * a[j + k * a_dim1] - a[j + (k + 1) * - a_dim1]); - wkp1 = t * (d22 * a[j + (k + 1) * a_dim1] - a[j + k * - a_dim1]); + wk = t * ((d11 * a[j + k * a_dim1] - a[j + (k + 1) * + a_dim1]) / d21); + wkp1 = t * ((d22 * a[j + (k + 1) * a_dim1] - a[j + k * + a_dim1]) / d21); /* Perform a rank-2 update of A(k+2:n,k+2:n) */ i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ - + k * a_dim1] / d21 * wk - a[i__ + (k + 1) - * a_dim1] / d21 * wkp1; + + k * a_dim1] * wk - a[i__ + (k + 1) * + a_dim1] * wkp1; /* L50: */ } /* Store L(k) and L(k+1) in cols k and k+1 for row J */ - a[j + k * a_dim1] = wk / d21; - a[j + (k + 1) * a_dim1] = wkp1 / d21; + a[j + k * a_dim1] = wk; + a[j + (k + 1) * a_dim1] = wkp1; /* L60: */ } diff --git a/lapack-netlib/SRC/ssytf2_rk.f b/lapack-netlib/SRC/ssytf2_rk.f index 51130acd37..12e76adc80 100644 --- a/lapack-netlib/SRC/ssytf2_rk.f +++ b/lapack-netlib/SRC/ssytf2_rk.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SSYTF2_RK + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -208,7 +206,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup singleSYcomputational +*> \ingroup hetf2_rk * *> \par Further Details: * ===================== @@ -238,6 +236,7 @@ * * ===================================================================== SUBROUTINE SSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -460,7 +459,8 @@ SUBROUTINE SSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * the interchanges in columns k+1:N. * IF( K.LT.N ) - $ CALL SSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA ) + $ CALL SSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), + $ LDA ) * END IF * @@ -475,7 +475,8 @@ SUBROUTINE SSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) IF( KP.GT.1 ) $ CALL SSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) - $ CALL SSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ CALL SSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, + $ KP+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) @@ -517,7 +518,8 @@ SUBROUTINE SSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * = A - W(k)*1/D(k)*W(k)**T * D11 = ONE / A( K, K ) - CALL SSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL SSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) * * Store U(k) in column k * @@ -536,7 +538,8 @@ SUBROUTINE SSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * = A - W(k)*(1/D(k))*W(k)**T * = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T * - CALL SSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL SSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) END IF * * Store the superdiagonal element of D in array E @@ -570,18 +573,18 @@ SUBROUTINE SSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) - WK = T*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - - $ ( A( I, K-1 ) / D12 )*WKM1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K-1 )*WKM1 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D12 - A( J, K-1 ) = WKM1 / D12 + A( J, K ) = WK + A( J, K-1 ) = WKM1 * 30 CONTINUE * @@ -694,14 +697,16 @@ SUBROUTINE SSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * Determine both ROWMAX and JMAX. * IF( IMAX.NE.K ) THEN - JMAX = K - 1 + ISAMAX( IMAX-K, A( IMAX, K ), LDA ) + JMAX = K - 1 + ISAMAX( IMAX-K, A( IMAX, K ), + $ LDA ) ROWMAX = ABS( A( IMAX, JMAX ) ) ELSE ROWMAX = ZERO END IF * IF( IMAX.LT.N ) THEN - ITEMP = IMAX + ISAMAX( N-IMAX, A( IMAX+1, IMAX ), + ITEMP = IMAX + ISAMAX( N-IMAX, A( IMAX+1, + $ IMAX ), $ 1 ) STEMP = ABS( A( ITEMP, IMAX ) ) IF( STEMP.GT.ROWMAX ) THEN @@ -760,7 +765,8 @@ SUBROUTINE SSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) IF( P.LT.N ) $ CALL SSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) IF( P.GT.(K+1) ) - $ CALL SSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + $ CALL SSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), + $ LDA ) T = A( K, K ) A( K, K ) = A( P, P ) A( P, P ) = T @@ -782,9 +788,11 @@ SUBROUTINE SSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * submatrix A(k:n,k:n) * IF( KP.LT.N ) - $ CALL SSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL SSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) - $ CALL SSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ CALL SSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, + $ KK+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) @@ -881,22 +889,22 @@ SUBROUTINE SSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N - A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - - $ ( A( I, K+1 ) / D21 )*WKP1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K+1 )*WKP1 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D21 - A( J, K+1 ) = WKP1 / D21 + A( J, K ) = WK + A( J, K+1 ) = WKP1 * 60 CONTINUE * diff --git a/lapack-netlib/SRC/ssytf2_rook.c b/lapack-netlib/SRC/ssytf2_rook.c index 8d9fdc9466..26752c1ff6 100644 --- a/lapack-netlib/SRC/ssytf2_rook.c +++ b/lapack-netlib/SRC/ssytf2_rook.c @@ -220,258 +220,6 @@ typedef struct Namelist Namelist; //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} -/* procedure parameter types for -A and -C++ */ - - -#ifdef __cplusplus -typedef logical (*L_fp)(...); -#else -typedef logical (*L_fp)(); -#endif -#if 0 -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#ifdef _MSC_VER -static _Fcomplex cpow_ui(complex x, integer n) { - complex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; - for(u = n; ; ) { - if(u & 01) pow.r *= x.r, pow.i *= x.i; - if(u >>= 1) x.r *= x.r, x.i *= x.i; - else break; - } - } - _Fcomplex p={pow.r, pow.i}; - return p; -} -#else -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -#ifdef _MSC_VER -static _Dcomplex zpow_ui(_Dcomplex x, integer n) { - _Dcomplex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; - for(u = n; ; ) { - if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; - if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; - else break; - } - } - _Dcomplex p = {pow._Val[0], pow._Val[1]}; - return p; -} -#else -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; - } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; -#ifdef _MSC_VER - _Fcomplex zdotc = {0.0, 0.0}; - if (incx == 1 && incy == 1) { - for (i=0;i \htmlonly */ /* > Download SSYTF2_ROOK + dependencies */ /* > */ @@ -496,7 +243,6 @@ rook.f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -608,9 +354,7 @@ rook.f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date November 2013 */ - -/* > \ingroup realSYcomputational */ +/* > \ingroup hetf2_rook */ /* > \par Further Details: */ /* ===================== */ @@ -679,12 +423,15 @@ rook.f"> */ real r__1; /* Local variables */ + integer i__, j, k, p; + real t, d11, d12, d21, d22; + integer ii, kk, kp; + real wk, wkm1, wkp1; logical done; integer imax, jmax; extern /* Subroutine */ void ssyr_(char *, integer *, real *, real *, integer *, real *, integer *); - integer i__, j, k, p; - real t, alpha; + real alpha; extern logical lsame_(char *, char *); extern /* Subroutine */ void sscal_(integer *, real *, real *, integer *); real sfmin; @@ -693,19 +440,16 @@ rook.f"> */ logical upper; extern /* Subroutine */ void sswap_(integer *, real *, integer *, real *, integer *); - real d11, d12, d21, d22; - integer ii, kk, kp; - real absakk, wk; + real absakk; extern real slamch_(char *); extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); extern integer isamax_(integer *, real *, integer *); - real colmax, rowmax, wkm1, wkp1; + real colmax, rowmax; -/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* November 2013 */ /* ===================================================================== */ @@ -715,7 +459,7 @@ rook.f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; @@ -1003,22 +747,22 @@ rook.f"> */ for (j = k - 2; j >= 1; --j) { - wkm1 = t * (d11 * a[j + (k - 1) * a_dim1] - a[j + k * - a_dim1]); - wk = t * (d22 * a[j + k * a_dim1] - a[j + (k - 1) * - a_dim1]); + wkm1 = t * ((d11 * a[j + (k - 1) * a_dim1] - a[j + k * + a_dim1]) / d12); + wk = t * ((d22 * a[j + k * a_dim1] - a[j + (k - 1) * + a_dim1]) / d12); for (i__ = j; i__ >= 1; --i__) { a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ - + k * a_dim1] / d12 * wk - a[i__ + (k - 1) - * a_dim1] / d12 * wkm1; + + k * a_dim1] * wk - a[i__ + (k - 1) * + a_dim1] * wkm1; /* L20: */ } /* Store U(k) and U(k-1) in cols k and k-1 for row J */ - a[j + k * a_dim1] = wk / d12; - a[j + (k - 1) * a_dim1] = wkm1 / d12; + a[j + k * a_dim1] = wk; + a[j + (k - 1) * a_dim1] = wkm1; /* L30: */ } @@ -1303,27 +1047,27 @@ rook.f"> */ i__1 = *n; for (j = k + 2; j <= i__1; ++j) { -/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ +/* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J */ - wk = t * (d11 * a[j + k * a_dim1] - a[j + (k + 1) * - a_dim1]); - wkp1 = t * (d22 * a[j + (k + 1) * a_dim1] - a[j + k * - a_dim1]); + wk = t * ((d11 * a[j + k * a_dim1] - a[j + (k + 1) * + a_dim1]) / d21); + wkp1 = t * ((d22 * a[j + (k + 1) * a_dim1] - a[j + k * + a_dim1]) / d21); /* Perform a rank-2 update of A(k+2:n,k+2:n) */ i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__ - + k * a_dim1] / d21 * wk - a[i__ + (k + 1) - * a_dim1] / d21 * wkp1; + + k * a_dim1] * wk - a[i__ + (k + 1) * + a_dim1] * wkp1; /* L50: */ } /* Store L(k) and L(k+1) in cols k and k+1 for row J */ - a[j + k * a_dim1] = wk / d21; - a[j + (k + 1) * a_dim1] = wkp1 / d21; + a[j + k * a_dim1] = wk; + a[j + (k + 1) * a_dim1] = wkp1; /* L60: */ } diff --git a/lapack-netlib/SRC/ssytf2_rook.f b/lapack-netlib/SRC/ssytf2_rook.f index 34dc12c732..dae4093a70 100644 --- a/lapack-netlib/SRC/ssytf2_rook.f +++ b/lapack-netlib/SRC/ssytf2_rook.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SSYTF2_ROOK + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -129,7 +127,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realSYcomputational +*> \ingroup hetf2_rook * *> \par Further Details: * ===================== @@ -191,6 +189,7 @@ * * ===================================================================== SUBROUTINE SSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -410,7 +409,8 @@ SUBROUTINE SSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) IF( KP.GT.1 ) $ CALL SSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) - $ CALL SSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ CALL SSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, + $ KP+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) @@ -444,7 +444,8 @@ SUBROUTINE SSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * = A - W(k)*1/D(k)*W(k)**T * D11 = ONE / A( K, K ) - CALL SSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL SSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) * * Store U(k) in column k * @@ -463,7 +464,8 @@ SUBROUTINE SSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * = A - W(k)*(1/D(k))*W(k)**T * = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T * - CALL SSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL SSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) END IF END IF * @@ -492,18 +494,18 @@ SUBROUTINE SSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) - WK = T*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - - $ ( A( I, K-1 ) / D12 )*WKM1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K-1 )*WKM1 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D12 - A( J, K-1 ) = WKM1 / D12 + A( J, K ) = WK + A( J, K-1 ) = WKM1 * 30 CONTINUE * @@ -593,14 +595,16 @@ SUBROUTINE SSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * Determine both ROWMAX and JMAX. * IF( IMAX.NE.K ) THEN - JMAX = K - 1 + ISAMAX( IMAX-K, A( IMAX, K ), LDA ) + JMAX = K - 1 + ISAMAX( IMAX-K, A( IMAX, K ), + $ LDA ) ROWMAX = ABS( A( IMAX, JMAX ) ) ELSE ROWMAX = ZERO END IF * IF( IMAX.LT.N ) THEN - ITEMP = IMAX + ISAMAX( N-IMAX, A( IMAX+1, IMAX ), + ITEMP = IMAX + ISAMAX( N-IMAX, A( IMAX+1, + $ IMAX ), $ 1 ) STEMP = ABS( A( ITEMP, IMAX ) ) IF( STEMP.GT.ROWMAX ) THEN @@ -659,7 +663,8 @@ SUBROUTINE SSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) IF( P.LT.N ) $ CALL SSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) IF( P.GT.(K+1) ) - $ CALL SSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + $ CALL SSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), + $ LDA ) T = A( K, K ) A( K, K ) = A( P, P ) A( P, P ) = T @@ -674,9 +679,11 @@ SUBROUTINE SSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * submatrix A(k:n,k:n) * IF( KP.LT.N ) - $ CALL SSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL SSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) - $ CALL SSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ CALL SSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, + $ KK+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) @@ -761,22 +768,22 @@ SUBROUTINE SSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N - A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - - $ ( A( I, K+1 ) / D21 )*WKP1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K+1 )*WKP1 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D21 - A( J, K+1 ) = WKP1 / D21 + A( J, K ) = WK + A( J, K+1 ) = WKP1 * 60 CONTINUE * diff --git a/lapack-netlib/SRC/zhetf2.c b/lapack-netlib/SRC/zhetf2.c index 581911643f..726f76293f 100644 --- a/lapack-netlib/SRC/zhetf2.c +++ b/lapack-netlib/SRC/zhetf2.c @@ -258,9 +258,6 @@ typedef struct Namelist Namelist; */ - - - /* Table of constant values */ static integer c__1 = 1; @@ -273,7 +270,6 @@ thod (unblocked algorithm, calling Level 2 BLAS). */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ZHETF2 + dependencies */ /* > */ @@ -284,7 +280,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -394,9 +389,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date November 2013 */ - -/* > \ingroup complex16HEcomputational */ +/* > \ingroup hetf2 */ /* > \par Further Details: */ /* ===================== */ @@ -465,42 +458,39 @@ f"> */ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6; /* Local variables */ - integer imax, jmax; - extern /* Subroutine */ void zher_(char *, integer *, doublereal *, - doublecomplex *, integer *, doublecomplex *, integer *); doublereal d__; integer i__, j, k; doublecomplex t; + doublereal r1, d11; + doublecomplex d12; + doublereal d22; + doublecomplex d21; + integer kk, kp; + doublecomplex wk; + doublereal tt; + doublecomplex wkm1, wkp1; + integer imax, jmax; + extern /* Subroutine */ void zher_(char *, integer *, doublereal *, + doublecomplex *, integer *, doublecomplex *, integer *); doublereal alpha; extern logical lsame_(char *, char *); integer kstep; logical upper; - doublereal r1; extern /* Subroutine */ void zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); extern doublereal dlapy2_(doublereal *, doublereal *); - doublereal d11; - doublecomplex d12; - doublereal d22; - doublecomplex d21; - integer kk, kp; doublereal absakk; - doublecomplex wk; - doublereal tt; extern logical disnan_(doublereal *); - extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - extern void zdscal_( + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), zdscal_( integer *, doublereal *, doublecomplex *, integer *); doublereal colmax; extern integer izamax_(integer *, doublecomplex *, integer *); doublereal rowmax; - doublecomplex wkm1, wkp1; -/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* November 2013 */ /* ===================================================================== */ @@ -510,7 +500,7 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; @@ -756,27 +746,28 @@ f"> */ i__1 = k - 1 + k * a_dim1; z__1.r = a[i__1].r / d__, z__1.i = a[i__1].i / d__; d12.r = z__1.r, d12.i = z__1.i; - d__ = tt / d__; for (j = k - 2; j >= 1; --j) { i__1 = j + (k - 1) * a_dim1; - z__3.r = d11 * a[i__1].r, z__3.i = d11 * a[i__1].i; - d_cnjg(&z__5, &d12); + z__4.r = d11 * a[i__1].r, z__4.i = d11 * a[i__1].i; + d_cnjg(&z__6, &d12); i__2 = j + k * a_dim1; - z__4.r = z__5.r * a[i__2].r - z__5.i * a[i__2].i, - z__4.i = z__5.r * a[i__2].i + z__5.i * a[i__2] + z__5.r = z__6.r * a[i__2].r - z__6.i * a[i__2].i, + z__5.i = z__6.r * a[i__2].i + z__6.i * a[i__2] .r; - z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; - z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i; + z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i; + z__2.r = z__3.r / d__, z__2.i = z__3.i / d__; + z__1.r = tt * z__2.r, z__1.i = tt * z__2.i; wkm1.r = z__1.r, wkm1.i = z__1.i; i__1 = j + k * a_dim1; - z__3.r = d22 * a[i__1].r, z__3.i = d22 * a[i__1].i; + z__4.r = d22 * a[i__1].r, z__4.i = d22 * a[i__1].i; i__2 = j + (k - 1) * a_dim1; - z__4.r = d12.r * a[i__2].r - d12.i * a[i__2].i, - z__4.i = d12.r * a[i__2].i + d12.i * a[i__2] + z__5.r = d12.r * a[i__2].r - d12.i * a[i__2].i, + z__5.i = d12.r * a[i__2].i + d12.i * a[i__2] .r; - z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; - z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i; + z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i; + z__2.r = z__3.r / d__, z__2.i = z__3.i / d__; + z__1.r = tt * z__2.r, z__1.i = tt * z__2.i; wk.r = z__1.r, wk.i = z__1.i; for (i__ = j; i__ >= 1; --i__) { i__1 = i__ + j * a_dim1; @@ -1054,28 +1045,29 @@ f"> */ i__1 = k + 1 + k * a_dim1; z__1.r = a[i__1].r / d__, z__1.i = a[i__1].i / d__; d21.r = z__1.r, d21.i = z__1.i; - d__ = tt / d__; i__1 = *n; for (j = k + 2; j <= i__1; ++j) { i__2 = j + k * a_dim1; - z__3.r = d11 * a[i__2].r, z__3.i = d11 * a[i__2].i; + z__4.r = d11 * a[i__2].r, z__4.i = d11 * a[i__2].i; i__3 = j + (k + 1) * a_dim1; - z__4.r = d21.r * a[i__3].r - d21.i * a[i__3].i, - z__4.i = d21.r * a[i__3].i + d21.i * a[i__3] + z__5.r = d21.r * a[i__3].r - d21.i * a[i__3].i, + z__5.i = d21.r * a[i__3].i + d21.i * a[i__3] .r; - z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; - z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i; + z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i; + z__2.r = z__3.r / d__, z__2.i = z__3.i / d__; + z__1.r = tt * z__2.r, z__1.i = tt * z__2.i; wk.r = z__1.r, wk.i = z__1.i; i__2 = j + (k + 1) * a_dim1; - z__3.r = d22 * a[i__2].r, z__3.i = d22 * a[i__2].i; - d_cnjg(&z__5, &d21); + z__4.r = d22 * a[i__2].r, z__4.i = d22 * a[i__2].i; + d_cnjg(&z__6, &d21); i__3 = j + k * a_dim1; - z__4.r = z__5.r * a[i__3].r - z__5.i * a[i__3].i, - z__4.i = z__5.r * a[i__3].i + z__5.i * a[i__3] + z__5.r = z__6.r * a[i__3].r - z__6.i * a[i__3].i, + z__5.i = z__6.r * a[i__3].i + z__6.i * a[i__3] .r; - z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; - z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i; + z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i; + z__2.r = z__3.r / d__, z__2.i = z__3.i / d__; + z__1.r = tt * z__2.r, z__1.i = tt * z__2.i; wkp1.r = z__1.r, wkp1.i = z__1.i; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { diff --git a/lapack-netlib/SRC/zhetf2.f b/lapack-netlib/SRC/zhetf2.f index 7a64951c71..40a7b03988 100644 --- a/lapack-netlib/SRC/zhetf2.f +++ b/lapack-netlib/SRC/zhetf2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZHETF2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -127,7 +125,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16HEcomputational +*> \ingroup hetf2 * *> \par Further Details: * ===================== @@ -188,6 +186,7 @@ * * ===================================================================== SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -289,7 +288,8 @@ SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO ) COLMAX = ZERO END IF * - IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. + $ DISNAN(ABSAKK) ) THEN * * Column K is zero or underflow, or contains a NaN: * set INFO and continue @@ -418,12 +418,11 @@ SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO ) D11 = DBLE( A( K, K ) ) / D TT = ONE / ( D11*D22-ONE ) D12 = A( K-1, K ) / D - D = TT / D * DO 40 J = K - 2, 1, -1 - WKM1 = D*( D11*A( J, K-1 )-DCONJG( D12 )* - $ A( J, K ) ) - WK = D*( D22*A( J, K )-D12*A( J, K-1 ) ) + WKM1 = TT*( ( D11*A( J, K-1 )-DCONJG( D12 )* + $ A( J, K ) ) / D ) + WK = TT*( ( D22*A( J, K )-D12*A( J, K-1 ) ) / D ) DO 30 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*DCONJG( WK ) - $ A( I, K-1 )*DCONJG( WKM1 ) @@ -484,7 +483,8 @@ SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO ) COLMAX = ZERO END IF * - IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. + $ DISNAN(ABSAKK) ) THEN * * Column K is zero or underflow, or contains a NaN: * set INFO and continue @@ -513,7 +513,8 @@ SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO ) JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA ) ROWMAX = CABS1( A( IMAX, JMAX ) ) IF( IMAX.LT.N ) THEN - JMAX = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 ) + JMAX = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) ROWMAX = MAX( ROWMAX, CABS1( A( JMAX, IMAX ) ) ) END IF * @@ -550,7 +551,8 @@ SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO ) * submatrix A(k:n,k:n) * IF( KP.LT.N ) - $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) DO 60 J = KK + 1, KP - 1 T = DCONJG( A( J, KK ) ) A( J, KK ) = DCONJG( A( KP, J ) ) @@ -616,12 +618,11 @@ SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO ) D22 = DBLE( A( K, K ) ) / D TT = ONE / ( D11*D22-ONE ) D21 = A( K+1, K ) / D - D = TT / D * DO 80 J = K + 2, N - WK = D*( D11*A( J, K )-D21*A( J, K+1 ) ) - WKP1 = D*( D22*A( J, K+1 )-DCONJG( D21 )* - $ A( J, K ) ) + WK = TT*( ( D11*A( J, K )-D21*A( J, K+1 ) ) / D ) + WKP1 = TT*( ( D22*A( J, K+1 )-DCONJG( D21 )* + $ A( J, K ) ) / D ) DO 70 I = J, N A( I, J ) = A( I, J ) - A( I, K )*DCONJG( WK ) - $ A( I, K+1 )*DCONJG( WKP1 ) diff --git a/lapack-netlib/SRC/zhetf2_rk.c b/lapack-netlib/SRC/zhetf2_rk.c index 8ee6763894..89fa112e59 100644 --- a/lapack-netlib/SRC/zhetf2_rk.c +++ b/lapack-netlib/SRC/zhetf2_rk.c @@ -258,8 +258,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__1 = 1; @@ -272,7 +270,6 @@ static integer c__1 = 1; /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ZHETF2_RK + dependencies */ /* > */ @@ -283,7 +280,6 @@ rk.f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -474,9 +470,7 @@ rk.f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complex16HEcomputational */ +/* > \ingroup hetf2_rk */ /* > \par Further Details: */ /* ===================== */ @@ -511,48 +505,43 @@ rk.f"> */ /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; doublereal d__1, d__2; - doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8; + doublecomplex z__1, z__2, z__3, z__4, z__5, z__6; /* Local variables */ + doublereal d__; + integer i__, j, k, p; + doublecomplex t; + doublereal r1, d11; + doublecomplex d12; + doublereal d22; + doublecomplex d21; + integer ii, kk, kp; + doublecomplex wk; + doublereal tt; + doublecomplex wkm1, wkp1; logical done; integer imax, jmax; extern /* Subroutine */ void zher_(char *, integer *, doublereal *, doublecomplex *, integer *, doublecomplex *, integer *); - doublereal d__; - integer i__, j, k, p; - doublecomplex t; doublereal alpha; extern logical lsame_(char *, char *); doublereal dtemp, sfmin; integer itemp, kstep; logical upper; - doublereal r1; extern /* Subroutine */ void zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); - extern doublereal dlapy2_(doublereal *, doublereal *); - doublereal d11; - doublecomplex d12; - doublereal d22; - doublecomplex d21; - integer ii, kk; - extern doublereal dlamch_(char *); - integer kp; + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *); doublereal absakk; - doublecomplex wk; - doublereal tt; - extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - extern void zdscal_( + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), zdscal_( integer *, doublereal *, doublecomplex *, integer *); doublereal colmax; extern integer izamax_(integer *, doublecomplex *, integer *); doublereal rowmax; - doublecomplex wkm1, wkp1; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ====================================================================== */ @@ -563,7 +552,7 @@ rk.f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --e; --ipiv; @@ -711,7 +700,7 @@ rk.f"> */ /* Case(2) */ /* Equivalent to testing for */ -/* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX */ +/* ABS( DBLE( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX */ /* (used to handle NaN and Inf) */ i__1 = imax + imax * a_dim1; @@ -784,7 +773,7 @@ rk.f"> */ a[i__2].r = t.r, a[i__2].i = t.i; /* L14: */ } -/* (3) Swap and conjugate corner elements at row-col interserction */ +/* (3) Swap and conjugate corner elements at row-col intersection */ i__1 = p + k * a_dim1; d_cnjg(&z__1, &a[p + k * a_dim1]); a[i__1].r = z__1.r, a[i__1].i = z__1.i; @@ -831,7 +820,7 @@ rk.f"> */ a[i__2].r = t.r, a[i__2].i = t.i; /* L15: */ } -/* (3) Swap and conjugate corner elements at row-col interserction */ +/* (3) Swap and conjugate corner elements at row-col intersection */ i__1 = kp + kk * a_dim1; d_cnjg(&z__1, &a[kp + kk * a_dim1]); a[i__1].r = z__1.r, a[i__1].i = z__1.i; @@ -986,25 +975,27 @@ rk.f"> */ for (j = k - 2; j >= 1; --j) { -/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ +/* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J */ i__1 = j + (k - 1) * a_dim1; - z__3.r = d11 * a[i__1].r, z__3.i = d11 * a[i__1].i; - d_cnjg(&z__5, &d12); + z__4.r = d11 * a[i__1].r, z__4.i = d11 * a[i__1].i; + d_cnjg(&z__6, &d12); i__2 = j + k * a_dim1; - z__4.r = z__5.r * a[i__2].r - z__5.i * a[i__2].i, - z__4.i = z__5.r * a[i__2].i + z__5.i * a[i__2] + z__5.r = z__6.r * a[i__2].r - z__6.i * a[i__2].i, + z__5.i = z__6.r * a[i__2].i + z__6.i * a[i__2] .r; - z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; + z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i; + z__2.r = z__3.r / d__, z__2.i = z__3.i / d__; z__1.r = tt * z__2.r, z__1.i = tt * z__2.i; wkm1.r = z__1.r, wkm1.i = z__1.i; i__1 = j + k * a_dim1; - z__3.r = d22 * a[i__1].r, z__3.i = d22 * a[i__1].i; + z__4.r = d22 * a[i__1].r, z__4.i = d22 * a[i__1].i; i__2 = j + (k - 1) * a_dim1; - z__4.r = d12.r * a[i__2].r - d12.i * a[i__2].i, - z__4.i = d12.r * a[i__2].i + d12.i * a[i__2] + z__5.r = d12.r * a[i__2].r - d12.i * a[i__2].i, + z__5.i = d12.r * a[i__2].i + d12.i * a[i__2] .r; - z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; + z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i; + z__2.r = z__3.r / d__, z__2.i = z__3.i / d__; z__1.r = tt * z__2.r, z__1.i = tt * z__2.i; wk.r = z__1.r, wk.i = z__1.i; @@ -1014,23 +1005,19 @@ rk.f"> */ i__1 = i__ + j * a_dim1; i__2 = i__ + j * a_dim1; i__3 = i__ + k * a_dim1; - z__4.r = a[i__3].r / d__, z__4.i = a[i__3].i / - d__; - d_cnjg(&z__5, &wk); - z__3.r = z__4.r * z__5.r - z__4.i * z__5.i, - z__3.i = z__4.r * z__5.i + z__4.i * - z__5.r; + d_cnjg(&z__4, &wk); + z__3.r = a[i__3].r * z__4.r - a[i__3].i * z__4.i, + z__3.i = a[i__3].r * z__4.i + a[i__3].i * + z__4.r; z__2.r = a[i__2].r - z__3.r, z__2.i = a[i__2].i - z__3.i; i__4 = i__ + (k - 1) * a_dim1; - z__7.r = a[i__4].r / d__, z__7.i = a[i__4].i / - d__; - d_cnjg(&z__8, &wkm1); - z__6.r = z__7.r * z__8.r - z__7.i * z__8.i, - z__6.i = z__7.r * z__8.i + z__7.i * - z__8.r; - z__1.r = z__2.r - z__6.r, z__1.i = z__2.i - - z__6.i; + d_cnjg(&z__6, &wkm1); + z__5.r = a[i__4].r * z__6.r - a[i__4].i * z__6.i, + z__5.i = a[i__4].r * z__6.i + a[i__4].i * + z__6.r; + z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - + z__5.i; a[i__1].r = z__1.r, a[i__1].i = z__1.i; /* L20: */ } @@ -1038,11 +1025,9 @@ rk.f"> */ /* Store U(k) and U(k-1) in cols k and k-1 for row J */ i__1 = j + k * a_dim1; - z__1.r = wk.r / d__, z__1.i = wk.i / d__; - a[i__1].r = z__1.r, a[i__1].i = z__1.i; + a[i__1].r = wk.r, a[i__1].i = wk.i; i__1 = j + (k - 1) * a_dim1; - z__1.r = wkm1.r / d__, z__1.i = wkm1.i / d__; - a[i__1].r = z__1.r, a[i__1].i = z__1.i; + a[i__1].r = wkm1.r, a[i__1].i = wkm1.i; /* (*) Make sure that diagonal element of pivot is real */ i__1 = j + j * a_dim1; i__2 = j + j * a_dim1; @@ -1208,7 +1193,7 @@ rk.f"> */ /* Case(2) */ /* Equivalent to testing for */ -/* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX */ +/* ABS( DBLE( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX */ /* (used to handle NaN and Inf) */ i__1 = imax + imax * a_dim1; @@ -1282,7 +1267,7 @@ rk.f"> */ a[i__2].r = t.r, a[i__2].i = t.i; /* L44: */ } -/* (3) Swap and conjugate corner elements at row-col interserction */ +/* (3) Swap and conjugate corner elements at row-col intersection */ i__1 = p + k * a_dim1; d_cnjg(&z__1, &a[p + k * a_dim1]); a[i__1].r = z__1.r, a[i__1].i = z__1.i; @@ -1328,7 +1313,7 @@ rk.f"> */ a[i__2].r = t.r, a[i__2].i = t.i; /* L45: */ } -/* (3) Swap and conjugate corner elements at row-col interserction */ +/* (3) Swap and conjugate corner elements at row-col intersection */ i__1 = kp + kk * a_dim1; d_cnjg(&z__1, &a[kp + kk * a_dim1]); a[i__1].r = z__1.r, a[i__1].i = z__1.i; @@ -1484,25 +1469,27 @@ rk.f"> */ i__1 = *n; for (j = k + 2; j <= i__1; ++j) { -/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ +/* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J */ i__2 = j + k * a_dim1; - z__3.r = d11 * a[i__2].r, z__3.i = d11 * a[i__2].i; + z__4.r = d11 * a[i__2].r, z__4.i = d11 * a[i__2].i; i__3 = j + (k + 1) * a_dim1; - z__4.r = d21.r * a[i__3].r - d21.i * a[i__3].i, - z__4.i = d21.r * a[i__3].i + d21.i * a[i__3] + z__5.r = d21.r * a[i__3].r - d21.i * a[i__3].i, + z__5.i = d21.r * a[i__3].i + d21.i * a[i__3] .r; - z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; + z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i; + z__2.r = z__3.r / d__, z__2.i = z__3.i / d__; z__1.r = tt * z__2.r, z__1.i = tt * z__2.i; wk.r = z__1.r, wk.i = z__1.i; i__2 = j + (k + 1) * a_dim1; - z__3.r = d22 * a[i__2].r, z__3.i = d22 * a[i__2].i; - d_cnjg(&z__5, &d21); + z__4.r = d22 * a[i__2].r, z__4.i = d22 * a[i__2].i; + d_cnjg(&z__6, &d21); i__3 = j + k * a_dim1; - z__4.r = z__5.r * a[i__3].r - z__5.i * a[i__3].i, - z__4.i = z__5.r * a[i__3].i + z__5.i * a[i__3] + z__5.r = z__6.r * a[i__3].r - z__6.i * a[i__3].i, + z__5.i = z__6.r * a[i__3].i + z__6.i * a[i__3] .r; - z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; + z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i; + z__2.r = z__3.r / d__, z__2.i = z__3.i / d__; z__1.r = tt * z__2.r, z__1.i = tt * z__2.i; wkp1.r = z__1.r, wkp1.i = z__1.i; @@ -1513,23 +1500,19 @@ rk.f"> */ i__3 = i__ + j * a_dim1; i__4 = i__ + j * a_dim1; i__5 = i__ + k * a_dim1; - z__4.r = a[i__5].r / d__, z__4.i = a[i__5].i / - d__; - d_cnjg(&z__5, &wk); - z__3.r = z__4.r * z__5.r - z__4.i * z__5.i, - z__3.i = z__4.r * z__5.i + z__4.i * - z__5.r; + d_cnjg(&z__4, &wk); + z__3.r = a[i__5].r * z__4.r - a[i__5].i * z__4.i, + z__3.i = a[i__5].r * z__4.i + a[i__5].i * + z__4.r; z__2.r = a[i__4].r - z__3.r, z__2.i = a[i__4].i - z__3.i; i__6 = i__ + (k + 1) * a_dim1; - z__7.r = a[i__6].r / d__, z__7.i = a[i__6].i / - d__; - d_cnjg(&z__8, &wkp1); - z__6.r = z__7.r * z__8.r - z__7.i * z__8.i, - z__6.i = z__7.r * z__8.i + z__7.i * - z__8.r; - z__1.r = z__2.r - z__6.r, z__1.i = z__2.i - - z__6.i; + d_cnjg(&z__6, &wkp1); + z__5.r = a[i__6].r * z__6.r - a[i__6].i * z__6.i, + z__5.i = a[i__6].r * z__6.i + a[i__6].i * + z__6.r; + z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - + z__5.i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L50: */ } @@ -1537,11 +1520,9 @@ rk.f"> */ /* Store L(k) and L(k+1) in cols k and k+1 for row J */ i__2 = j + k * a_dim1; - z__1.r = wk.r / d__, z__1.i = wk.i / d__; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; + a[i__2].r = wk.r, a[i__2].i = wk.i; i__2 = j + (k + 1) * a_dim1; - z__1.r = wkp1.r / d__, z__1.i = wkp1.i / d__; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; + a[i__2].r = wkp1.r, a[i__2].i = wkp1.i; /* (*) Make sure that diagonal element of pivot is real */ i__2 = j + j * a_dim1; i__3 = j + j * a_dim1; diff --git a/lapack-netlib/SRC/zhetf2_rk.f b/lapack-netlib/SRC/zhetf2_rk.f index 87df901aa2..b8c9bc905b 100644 --- a/lapack-netlib/SRC/zhetf2_rk.f +++ b/lapack-netlib/SRC/zhetf2_rk.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZHETF2_RK + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -208,7 +206,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16HEcomputational +*> \ingroup hetf2_rk * *> \par Further Details: * ===================== @@ -238,6 +236,7 @@ * * ===================================================================== SUBROUTINE ZHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -491,7 +490,8 @@ SUBROUTINE ZHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * the interchanges in columns k+1:N. * IF( K.LT.N ) - $ CALL ZSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA ) + $ CALL ZSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), + $ LDA ) * END IF * @@ -560,7 +560,8 @@ SUBROUTINE ZHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * = A - W(k)*1/D(k)*W(k)**T * D11 = ONE / DBLE( A( K, K ) ) - CALL ZHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL ZHER( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) * * Store U(k) in column k * @@ -579,7 +580,8 @@ SUBROUTINE ZHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * = A - W(k)*(1/D(k))*W(k)**T * = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T * - CALL ZHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL ZHER( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) END IF * * Store the superdiagonal element of D in array E @@ -615,24 +617,24 @@ SUBROUTINE ZHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WKM1 = TT*( D11*A( J, K-1 )-DCONJG( D12 )* - $ A( J, K ) ) - WK = TT*( D22*A( J, K )-D12*A( J, K-1 ) ) + WKM1 = TT*( ( D11*A( J, K-1 )-DCONJG( D12 )* + $ A( J, K ) ) / D ) + WK = TT*( ( D22*A( J, K )-D12*A( J, K-1 ) ) / D ) * * Perform a rank-2 update of A(1:k-2,1:k-2) * DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - - $ ( A( I, K ) / D )*DCONJG( WK ) - - $ ( A( I, K-1 ) / D )*DCONJG( WKM1 ) + $ A( I, K )*DCONJG( WK ) - + $ A( I, K-1 )*DCONJG( WKM1 ) 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D - A( J, K-1 ) = WKM1 / D + A( J, K ) = WK + A( J, K-1 ) = WKM1 * (*) Make sure that diagonal element of pivot is real A( J, J ) = DCMPLX( DBLE( A( J, J ) ), ZERO ) * @@ -752,14 +754,16 @@ SUBROUTINE ZHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * Determine both ROWMAX and JMAX. * IF( IMAX.NE.K ) THEN - JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA ) + JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), + $ LDA ) ROWMAX = CABS1( A( IMAX, JMAX ) ) ELSE ROWMAX = ZERO END IF * IF( IMAX.LT.N ) THEN - ITEMP = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ), + ITEMP = IMAX + IZAMAX( N-IMAX, A( IMAX+1, + $ IMAX ), $ 1 ) DTEMP = CABS1( A( ITEMP, IMAX ) ) IF( DTEMP.GT.ROWMAX ) THEN @@ -855,7 +859,8 @@ SUBROUTINE ZHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) IF( KP.NE.KK ) THEN * (1) Swap columnar parts IF( KP.LT.N ) - $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) * (2) Swap and conjugate middle parts DO 45 J = KK + 1, KP - 1 T = DCONJG( A( J, KK ) ) @@ -973,24 +978,24 @@ SUBROUTINE ZHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = TT*( D11*A( J, K )-D21*A( J, K+1 ) ) - WKP1 = TT*( D22*A( J, K+1 )-DCONJG( D21 )* - $ A( J, K ) ) + WK = TT*( ( D11*A( J, K )-D21*A( J, K+1 ) ) / D ) + WKP1 = TT*( ( D22*A( J, K+1 )-DCONJG( D21 )* + $ A( J, K ) ) / D ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N A( I, J ) = A( I, J ) - - $ ( A( I, K ) / D )*DCONJG( WK ) - - $ ( A( I, K+1 ) / D )*DCONJG( WKP1 ) + $ A( I, K )*DCONJG( WK ) - + $ A( I, K+1 )*DCONJG( WKP1 ) 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D - A( J, K+1 ) = WKP1 / D + A( J, K ) = WK + A( J, K+1 ) = WKP1 * (*) Make sure that diagonal element of pivot is real A( J, J ) = DCMPLX( DBLE( A( J, J ) ), ZERO ) * diff --git a/lapack-netlib/SRC/zhetf2_rook.c b/lapack-netlib/SRC/zhetf2_rook.c index a59cdbb498..de155d0388 100644 --- a/lapack-netlib/SRC/zhetf2_rook.c +++ b/lapack-netlib/SRC/zhetf2_rook.c @@ -258,8 +258,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__1 = 1; @@ -272,7 +270,6 @@ ed Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm). */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ZHETF2_ROOK + dependencies */ /* > */ @@ -283,7 +280,6 @@ rook.f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -395,9 +391,7 @@ rook.f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date November 2013 */ - -/* > \ingroup complex16HEcomputational */ +/* > \ingroup hetf2_rook */ /* > \par Further Details: */ /* ===================== */ @@ -464,48 +458,43 @@ rook.f"> */ /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; doublereal d__1, d__2; - doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8; + doublecomplex z__1, z__2, z__3, z__4, z__5, z__6; /* Local variables */ + doublereal d__; + integer i__, j, k, p; + doublecomplex t; + doublereal r1, d11; + doublecomplex d12; + doublereal d22; + doublecomplex d21; + integer ii, kk, kp; + doublecomplex wk; + doublereal tt; + doublecomplex wkm1, wkp1; logical done; integer imax, jmax; extern /* Subroutine */ void zher_(char *, integer *, doublereal *, doublecomplex *, integer *, doublecomplex *, integer *); - doublereal d__; - integer i__, j, k, p; - doublecomplex t; doublereal alpha; extern logical lsame_(char *, char *); doublereal dtemp, sfmin; integer itemp, kstep; logical upper; - doublereal r1; extern /* Subroutine */ void zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); - extern doublereal dlapy2_(doublereal *, doublereal *); - doublereal d11; - doublecomplex d12; - doublereal d22; - doublecomplex d21; - integer ii, kk; - extern doublereal dlamch_(char *); - integer kp; + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *); doublereal absakk; - doublecomplex wk; - doublereal tt; - extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - extern void zdscal_( + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), zdscal_( integer *, doublereal *, doublecomplex *, integer *); doublereal colmax; extern integer izamax_(integer *, doublecomplex *, integer *); doublereal rowmax; - doublecomplex wkm1, wkp1; -/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* November 2013 */ /* ====================================================================== */ @@ -516,7 +505,7 @@ rook.f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; @@ -650,7 +639,7 @@ rook.f"> */ /* Case(2) */ /* Equivalent to testing for */ -/* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX */ +/* ABS( DBLE( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX */ /* (used to handle NaN and Inf) */ i__1 = imax + imax * a_dim1; @@ -723,7 +712,7 @@ rook.f"> */ a[i__2].r = t.r, a[i__2].i = t.i; /* L14: */ } -/* (3) Swap and conjugate corner elements at row-col interserction */ +/* (3) Swap and conjugate corner elements at row-col intersection */ i__1 = p + k * a_dim1; d_cnjg(&z__1, &a[p + k * a_dim1]); a[i__1].r = z__1.r, a[i__1].i = z__1.i; @@ -760,7 +749,7 @@ rook.f"> */ a[i__2].r = t.r, a[i__2].i = t.i; /* L15: */ } -/* (3) Swap and conjugate corner elements at row-col interserction */ +/* (3) Swap and conjugate corner elements at row-col intersection */ i__1 = kp + kk * a_dim1; d_cnjg(&z__1, &a[kp + kk * a_dim1]); a[i__1].r = z__1.r, a[i__1].i = z__1.i; @@ -899,25 +888,27 @@ rook.f"> */ for (j = k - 2; j >= 1; --j) { -/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ +/* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J */ i__1 = j + (k - 1) * a_dim1; - z__3.r = d11 * a[i__1].r, z__3.i = d11 * a[i__1].i; - d_cnjg(&z__5, &d12); + z__4.r = d11 * a[i__1].r, z__4.i = d11 * a[i__1].i; + d_cnjg(&z__6, &d12); i__2 = j + k * a_dim1; - z__4.r = z__5.r * a[i__2].r - z__5.i * a[i__2].i, - z__4.i = z__5.r * a[i__2].i + z__5.i * a[i__2] + z__5.r = z__6.r * a[i__2].r - z__6.i * a[i__2].i, + z__5.i = z__6.r * a[i__2].i + z__6.i * a[i__2] .r; - z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; + z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i; + z__2.r = z__3.r / d__, z__2.i = z__3.i / d__; z__1.r = tt * z__2.r, z__1.i = tt * z__2.i; wkm1.r = z__1.r, wkm1.i = z__1.i; i__1 = j + k * a_dim1; - z__3.r = d22 * a[i__1].r, z__3.i = d22 * a[i__1].i; + z__4.r = d22 * a[i__1].r, z__4.i = d22 * a[i__1].i; i__2 = j + (k - 1) * a_dim1; - z__4.r = d12.r * a[i__2].r - d12.i * a[i__2].i, - z__4.i = d12.r * a[i__2].i + d12.i * a[i__2] + z__5.r = d12.r * a[i__2].r - d12.i * a[i__2].i, + z__5.i = d12.r * a[i__2].i + d12.i * a[i__2] .r; - z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; + z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i; + z__2.r = z__3.r / d__, z__2.i = z__3.i / d__; z__1.r = tt * z__2.r, z__1.i = tt * z__2.i; wk.r = z__1.r, wk.i = z__1.i; @@ -927,23 +918,19 @@ rook.f"> */ i__1 = i__ + j * a_dim1; i__2 = i__ + j * a_dim1; i__3 = i__ + k * a_dim1; - z__4.r = a[i__3].r / d__, z__4.i = a[i__3].i / - d__; - d_cnjg(&z__5, &wk); - z__3.r = z__4.r * z__5.r - z__4.i * z__5.i, - z__3.i = z__4.r * z__5.i + z__4.i * - z__5.r; + d_cnjg(&z__4, &wk); + z__3.r = a[i__3].r * z__4.r - a[i__3].i * z__4.i, + z__3.i = a[i__3].r * z__4.i + a[i__3].i * + z__4.r; z__2.r = a[i__2].r - z__3.r, z__2.i = a[i__2].i - z__3.i; i__4 = i__ + (k - 1) * a_dim1; - z__7.r = a[i__4].r / d__, z__7.i = a[i__4].i / - d__; - d_cnjg(&z__8, &wkm1); - z__6.r = z__7.r * z__8.r - z__7.i * z__8.i, - z__6.i = z__7.r * z__8.i + z__7.i * - z__8.r; - z__1.r = z__2.r - z__6.r, z__1.i = z__2.i - - z__6.i; + d_cnjg(&z__6, &wkm1); + z__5.r = a[i__4].r * z__6.r - a[i__4].i * z__6.i, + z__5.i = a[i__4].r * z__6.i + a[i__4].i * + z__6.r; + z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - + z__5.i; a[i__1].r = z__1.r, a[i__1].i = z__1.i; /* L20: */ } @@ -951,11 +938,9 @@ rook.f"> */ /* Store U(k) and U(k-1) in cols k and k-1 for row J */ i__1 = j + k * a_dim1; - z__1.r = wk.r / d__, z__1.i = wk.i / d__; - a[i__1].r = z__1.r, a[i__1].i = z__1.i; + a[i__1].r = wk.r, a[i__1].i = wk.i; i__1 = j + (k - 1) * a_dim1; - z__1.r = wkm1.r / d__, z__1.i = wkm1.i / d__; - a[i__1].r = z__1.r, a[i__1].i = z__1.i; + a[i__1].r = wkm1.r, a[i__1].i = wkm1.i; /* (*) Make sure that diagonal element of pivot is real */ i__1 = j + j * a_dim1; i__2 = j + j * a_dim1; @@ -1092,7 +1077,7 @@ rook.f"> */ /* Case(2) */ /* Equivalent to testing for */ -/* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX */ +/* ABS( DBLE( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX */ /* (used to handle NaN and Inf) */ i__1 = imax + imax * a_dim1; @@ -1166,7 +1151,7 @@ rook.f"> */ a[i__2].r = t.r, a[i__2].i = t.i; /* L44: */ } -/* (3) Swap and conjugate corner elements at row-col interserction */ +/* (3) Swap and conjugate corner elements at row-col intersection */ i__1 = p + k * a_dim1; d_cnjg(&z__1, &a[p + k * a_dim1]); a[i__1].r = z__1.r, a[i__1].i = z__1.i; @@ -1203,7 +1188,7 @@ rook.f"> */ a[i__2].r = t.r, a[i__2].i = t.i; /* L45: */ } -/* (3) Swap and conjugate corner elements at row-col interserction */ +/* (3) Swap and conjugate corner elements at row-col intersection */ i__1 = kp + kk * a_dim1; d_cnjg(&z__1, &a[kp + kk * a_dim1]); a[i__1].r = z__1.r, a[i__1].i = z__1.i; @@ -1344,25 +1329,27 @@ rook.f"> */ i__1 = *n; for (j = k + 2; j <= i__1; ++j) { -/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ +/* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J */ i__2 = j + k * a_dim1; - z__3.r = d11 * a[i__2].r, z__3.i = d11 * a[i__2].i; + z__4.r = d11 * a[i__2].r, z__4.i = d11 * a[i__2].i; i__3 = j + (k + 1) * a_dim1; - z__4.r = d21.r * a[i__3].r - d21.i * a[i__3].i, - z__4.i = d21.r * a[i__3].i + d21.i * a[i__3] + z__5.r = d21.r * a[i__3].r - d21.i * a[i__3].i, + z__5.i = d21.r * a[i__3].i + d21.i * a[i__3] .r; - z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; + z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i; + z__2.r = z__3.r / d__, z__2.i = z__3.i / d__; z__1.r = tt * z__2.r, z__1.i = tt * z__2.i; wk.r = z__1.r, wk.i = z__1.i; i__2 = j + (k + 1) * a_dim1; - z__3.r = d22 * a[i__2].r, z__3.i = d22 * a[i__2].i; - d_cnjg(&z__5, &d21); + z__4.r = d22 * a[i__2].r, z__4.i = d22 * a[i__2].i; + d_cnjg(&z__6, &d21); i__3 = j + k * a_dim1; - z__4.r = z__5.r * a[i__3].r - z__5.i * a[i__3].i, - z__4.i = z__5.r * a[i__3].i + z__5.i * a[i__3] + z__5.r = z__6.r * a[i__3].r - z__6.i * a[i__3].i, + z__5.i = z__6.r * a[i__3].i + z__6.i * a[i__3] .r; - z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; + z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i; + z__2.r = z__3.r / d__, z__2.i = z__3.i / d__; z__1.r = tt * z__2.r, z__1.i = tt * z__2.i; wkp1.r = z__1.r, wkp1.i = z__1.i; @@ -1373,23 +1360,19 @@ rook.f"> */ i__3 = i__ + j * a_dim1; i__4 = i__ + j * a_dim1; i__5 = i__ + k * a_dim1; - z__4.r = a[i__5].r / d__, z__4.i = a[i__5].i / - d__; - d_cnjg(&z__5, &wk); - z__3.r = z__4.r * z__5.r - z__4.i * z__5.i, - z__3.i = z__4.r * z__5.i + z__4.i * - z__5.r; + d_cnjg(&z__4, &wk); + z__3.r = a[i__5].r * z__4.r - a[i__5].i * z__4.i, + z__3.i = a[i__5].r * z__4.i + a[i__5].i * + z__4.r; z__2.r = a[i__4].r - z__3.r, z__2.i = a[i__4].i - z__3.i; i__6 = i__ + (k + 1) * a_dim1; - z__7.r = a[i__6].r / d__, z__7.i = a[i__6].i / - d__; - d_cnjg(&z__8, &wkp1); - z__6.r = z__7.r * z__8.r - z__7.i * z__8.i, - z__6.i = z__7.r * z__8.i + z__7.i * - z__8.r; - z__1.r = z__2.r - z__6.r, z__1.i = z__2.i - - z__6.i; + d_cnjg(&z__6, &wkp1); + z__5.r = a[i__6].r * z__6.r - a[i__6].i * z__6.i, + z__5.i = a[i__6].r * z__6.i + a[i__6].i * + z__6.r; + z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - + z__5.i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L50: */ } @@ -1397,11 +1380,9 @@ rook.f"> */ /* Store L(k) and L(k+1) in cols k and k+1 for row J */ i__2 = j + k * a_dim1; - z__1.r = wk.r / d__, z__1.i = wk.i / d__; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; + a[i__2].r = wk.r, a[i__2].i = wk.i; i__2 = j + (k + 1) * a_dim1; - z__1.r = wkp1.r / d__, z__1.i = wkp1.i / d__; - a[i__2].r = z__1.r, a[i__2].i = z__1.i; + a[i__2].r = wkp1.r, a[i__2].i = wkp1.i; /* (*) Make sure that diagonal element of pivot is real */ i__2 = j + j * a_dim1; i__3 = j + j * a_dim1; diff --git a/lapack-netlib/SRC/zhetf2_rook.f b/lapack-netlib/SRC/zhetf2_rook.f index 91172f6019..333150bcb4 100644 --- a/lapack-netlib/SRC/zhetf2_rook.f +++ b/lapack-netlib/SRC/zhetf2_rook.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZHETF2_ROOK + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -129,7 +127,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16HEcomputational +*> \ingroup hetf2_rook * *> \par Further Details: * ===================== @@ -191,6 +189,7 @@ * * ===================================================================== SUBROUTINE ZHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -485,7 +484,8 @@ SUBROUTINE ZHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * = A - W(k)*1/D(k)*W(k)**T * D11 = ONE / DBLE( A( K, K ) ) - CALL ZHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL ZHER( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) * * Store U(k) in column k * @@ -504,7 +504,8 @@ SUBROUTINE ZHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * = A - W(k)*(1/D(k))*W(k)**T * = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T * - CALL ZHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL ZHER( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) END IF END IF * @@ -535,24 +536,24 @@ SUBROUTINE ZHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WKM1 = TT*( D11*A( J, K-1 )-DCONJG( D12 )* - $ A( J, K ) ) - WK = TT*( D22*A( J, K )-D12*A( J, K-1 ) ) + WKM1 = TT*( ( D11*A( J, K-1 )-DCONJG( D12 )* + $ A( J, K ) ) / D ) + WK = TT*( ( D22*A( J, K )-D12*A( J, K-1 ) ) / D ) * * Perform a rank-2 update of A(1:k-2,1:k-2) * DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - - $ ( A( I, K ) / D )*DCONJG( WK ) - - $ ( A( I, K-1 ) / D )*DCONJG( WKM1 ) + $ A( I, K )*DCONJG( WK ) - + $ A( I, K-1 )*DCONJG( WKM1 ) 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D - A( J, K-1 ) = WKM1 / D + A( J, K ) = WK + A( J, K-1 ) = WKM1 * (*) Make sure that diagonal element of pivot is real A( J, J ) = DCMPLX( DBLE( A( J, J ) ), ZERO ) * @@ -651,14 +652,16 @@ SUBROUTINE ZHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * Determine both ROWMAX and JMAX. * IF( IMAX.NE.K ) THEN - JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA ) + JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), + $ LDA ) ROWMAX = CABS1( A( IMAX, JMAX ) ) ELSE ROWMAX = ZERO END IF * IF( IMAX.LT.N ) THEN - ITEMP = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ), + ITEMP = IMAX + IZAMAX( N-IMAX, A( IMAX+1, + $ IMAX ), $ 1 ) DTEMP = CABS1( A( ITEMP, IMAX ) ) IF( DTEMP.GT.ROWMAX ) THEN @@ -747,7 +750,8 @@ SUBROUTINE ZHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) IF( KP.NE.KK ) THEN * (1) Swap columnar parts IF( KP.LT.N ) - $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) * (2) Swap and conjugate middle parts DO 45 J = KK + 1, KP - 1 T = DCONJG( A( J, KK ) ) @@ -853,24 +857,24 @@ SUBROUTINE ZHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = TT*( D11*A( J, K )-D21*A( J, K+1 ) ) - WKP1 = TT*( D22*A( J, K+1 )-DCONJG( D21 )* - $ A( J, K ) ) + WK = TT*( ( D11*A( J, K )-D21*A( J, K+1 ) ) / D ) + WKP1 = TT*( ( D22*A( J, K+1 )-DCONJG( D21 )* + $ A( J, K ) ) / D ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N A( I, J ) = A( I, J ) - - $ ( A( I, K ) / D )*DCONJG( WK ) - - $ ( A( I, K+1 ) / D )*DCONJG( WKP1 ) + $ A( I, K )*DCONJG( WK ) - + $ A( I, K+1 )*DCONJG( WKP1 ) 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D - A( J, K+1 ) = WKP1 / D + A( J, K ) = WK + A( J, K+1 ) = WKP1 * (*) Make sure that diagonal element of pivot is real A( J, J ) = DCMPLX( DBLE( A( J, J ) ), ZERO ) * diff --git a/lapack-netlib/SRC/zhptrf.c b/lapack-netlib/SRC/zhptrf.c index 8438c052f8..cddb8e8dee 100644 --- a/lapack-netlib/SRC/zhptrf.c +++ b/lapack-netlib/SRC/zhptrf.c @@ -258,8 +258,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__1 = 1; @@ -271,7 +269,6 @@ static integer c__1 = 1; /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ZHPTRF + dependencies */ /* > */ @@ -282,7 +279,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -372,9 +368,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complex16OTHERcomputational */ +/* > \ingroup hptrf */ /* > \par Further Details: */ /* ===================== */ @@ -431,43 +425,41 @@ f"> */ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6; /* Local variables */ - integer imax, jmax; - extern /* Subroutine */ void zhpr_(char *, integer *, doublereal *, - doublecomplex *, integer *, doublecomplex *); doublereal d__; integer i__, j, k; doublecomplex t; + doublereal r1, d11; + doublecomplex d12; + doublereal d22; + doublecomplex d21; + integer kc, kk, kp; + doublecomplex wk; + integer kx; + doublereal tt; + integer knc, kpc, npp; + doublecomplex wkm1, wkp1; + integer imax, jmax; + extern /* Subroutine */ void zhpr_(char *, integer *, doublereal *, + doublecomplex *, integer *, doublecomplex *); doublereal alpha; extern logical lsame_(char *, char *); integer kstep; logical upper; - doublereal r1; extern /* Subroutine */ void zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); extern doublereal dlapy2_(doublereal *, doublereal *); - doublereal d11; - doublecomplex d12; - doublereal d22; - doublecomplex d21; - integer kc, kk, kp; doublereal absakk; - doublecomplex wk; - integer kx; - doublereal tt; - extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - extern void zdscal_( + extern logical disnan_(doublereal *); + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), zdscal_( integer *, doublereal *, doublecomplex *, integer *); doublereal colmax; extern integer izamax_(integer *, doublecomplex *, integer *); doublereal rowmax; - integer knc, kpc, npp; - doublecomplex wkm1, wkp1; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -535,9 +527,10 @@ f"> */ colmax = 0.; } - if (f2cmax(absakk,colmax) == 0.) { + if (f2cmax(absakk,colmax) == 0. || disnan_(&absakk)) { -/* Column K is zero: set INFO and continue */ +/* Column K is zero or underflow, or contains a NaN: */ +/* set INFO and continue */ if (*info == 0) { *info = k; @@ -722,27 +715,28 @@ f"> */ i__1 = k - 1 + (k - 1) * k / 2; z__1.r = ap[i__1].r / d__, z__1.i = ap[i__1].i / d__; d12.r = z__1.r, d12.i = z__1.i; - d__ = tt / d__; for (j = k - 2; j >= 1; --j) { i__1 = j + (k - 2) * (k - 1) / 2; - z__3.r = d11 * ap[i__1].r, z__3.i = d11 * ap[i__1].i; - d_cnjg(&z__5, &d12); + z__4.r = d11 * ap[i__1].r, z__4.i = d11 * ap[i__1].i; + d_cnjg(&z__6, &d12); i__2 = j + (k - 1) * k / 2; - z__4.r = z__5.r * ap[i__2].r - z__5.i * ap[i__2].i, - z__4.i = z__5.r * ap[i__2].i + z__5.i * ap[ + z__5.r = z__6.r * ap[i__2].r - z__6.i * ap[i__2].i, + z__5.i = z__6.r * ap[i__2].i + z__6.i * ap[ i__2].r; - z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; - z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i; + z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i; + z__2.r = z__3.r / d__, z__2.i = z__3.i / d__; + z__1.r = tt * z__2.r, z__1.i = tt * z__2.i; wkm1.r = z__1.r, wkm1.i = z__1.i; i__1 = j + (k - 1) * k / 2; - z__3.r = d22 * ap[i__1].r, z__3.i = d22 * ap[i__1].i; + z__4.r = d22 * ap[i__1].r, z__4.i = d22 * ap[i__1].i; i__2 = j + (k - 2) * (k - 1) / 2; - z__4.r = d12.r * ap[i__2].r - d12.i * ap[i__2].i, - z__4.i = d12.r * ap[i__2].i + d12.i * ap[i__2] + z__5.r = d12.r * ap[i__2].r - d12.i * ap[i__2].i, + z__5.i = d12.r * ap[i__2].i + d12.i * ap[i__2] .r; - z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; - z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i; + z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i; + z__2.r = z__3.r / d__, z__2.i = z__3.i / d__; + z__1.r = tt * z__2.r, z__1.i = tt * z__2.i; wk.r = z__1.r, wk.i = z__1.i; for (i__ = j; i__ >= 1; --i__) { i__1 = i__ + (j - 1) * j / 2; @@ -835,9 +829,10 @@ f"> */ colmax = 0.; } - if (f2cmax(absakk,colmax) == 0.) { + if (f2cmax(absakk,colmax) == 0. || disnan_(&absakk)) { -/* Column K is zero: set INFO and continue */ +/* Column K is zero or underflow, or contains a NaN: */ +/* set INFO and continue */ if (*info == 0) { *info = k; @@ -1031,28 +1026,29 @@ f"> */ i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2; z__1.r = ap[i__1].r / d__, z__1.i = ap[i__1].i / d__; d21.r = z__1.r, d21.i = z__1.i; - d__ = tt / d__; i__1 = *n; for (j = k + 2; j <= i__1; ++j) { i__2 = j + (k - 1) * ((*n << 1) - k) / 2; - z__3.r = d11 * ap[i__2].r, z__3.i = d11 * ap[i__2].i; + z__4.r = d11 * ap[i__2].r, z__4.i = d11 * ap[i__2].i; i__3 = j + k * ((*n << 1) - k - 1) / 2; - z__4.r = d21.r * ap[i__3].r - d21.i * ap[i__3].i, - z__4.i = d21.r * ap[i__3].i + d21.i * ap[i__3] + z__5.r = d21.r * ap[i__3].r - d21.i * ap[i__3].i, + z__5.i = d21.r * ap[i__3].i + d21.i * ap[i__3] .r; - z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; - z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i; + z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i; + z__2.r = z__3.r / d__, z__2.i = z__3.i / d__; + z__1.r = tt * z__2.r, z__1.i = tt * z__2.i; wk.r = z__1.r, wk.i = z__1.i; i__2 = j + k * ((*n << 1) - k - 1) / 2; - z__3.r = d22 * ap[i__2].r, z__3.i = d22 * ap[i__2].i; - d_cnjg(&z__5, &d21); + z__4.r = d22 * ap[i__2].r, z__4.i = d22 * ap[i__2].i; + d_cnjg(&z__6, &d21); i__3 = j + (k - 1) * ((*n << 1) - k) / 2; - z__4.r = z__5.r * ap[i__3].r - z__5.i * ap[i__3].i, - z__4.i = z__5.r * ap[i__3].i + z__5.i * ap[ + z__5.r = z__6.r * ap[i__3].r - z__6.i * ap[i__3].i, + z__5.i = z__6.r * ap[i__3].i + z__6.i * ap[ i__3].r; - z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; - z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i; + z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i; + z__2.r = z__3.r / d__, z__2.i = z__3.i / d__; + z__1.r = tt * z__2.r, z__1.i = tt * z__2.i; wkp1.r = z__1.r, wkp1.i = z__1.i; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { diff --git a/lapack-netlib/SRC/zhptrf.f b/lapack-netlib/SRC/zhptrf.f index 6558a1bb80..b7d22d2f00 100644 --- a/lapack-netlib/SRC/zhptrf.f +++ b/lapack-netlib/SRC/zhptrf.f @@ -389,13 +389,12 @@ SUBROUTINE ZHPTRF( UPLO, N, AP, IPIV, INFO ) D11 = DBLE( AP( K+( K-1 )*K / 2 ) ) / D TT = ONE / ( D11*D22-ONE ) D12 = AP( K-1+( K-1 )*K / 2 ) / D - D = TT / D * DO 50 J = K - 2, 1, -1 - WKM1 = D*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ DCONJG( D12 )*AP( J+( K-1 )*K / 2 ) ) - WK = D*( D22*AP( J+( K-1 )*K / 2 )-D12* - $ AP( J+( K-2 )*( K-1 ) / 2 ) ) + WKM1 = TT*( ( D11*AP( J+( K-2 )*( K-1 ) / 2 )- + $ DCONJG( D12 )*AP( J+( K-1 )*K / 2 ) ) / D ) + WK = TT*( ( D22*AP( J+( K-1 )*K / 2 )-D12* + $ AP( J+( K-2 )*( K-1 ) / 2 ) ) / D ) DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*DCONJG( WK ) - @@ -603,14 +602,13 @@ SUBROUTINE ZHPTRF( UPLO, N, AP, IPIV, INFO ) D22 = DBLE( AP( K+( K-1 )*( 2*N-K ) / 2 ) ) / D TT = ONE / ( D11*D22-ONE ) D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 ) / D - D = TT / D * DO 100 J = K + 2, N - WK = D*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-D21* - $ AP( J+K*( 2*N-K-1 ) / 2 ) ) - WKP1 = D*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- + WK = TT*( ( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-D21* + $ AP( J+K*( 2*N-K-1 ) / 2 ) ) / D ) + WKP1 = TT*( ( D22*AP( J+K*( 2*N-K-1 ) / 2 )- $ DCONJG( D21 )*AP( J+( K-1 )*( 2*N-K ) / - $ 2 ) ) + $ 2 ) ) / D ) DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / diff --git a/lapack-netlib/SRC/zlahef.c b/lapack-netlib/SRC/zlahef.c index 1051091480..626b5959dc 100644 --- a/lapack-netlib/SRC/zlahef.c +++ b/lapack-netlib/SRC/zlahef.c @@ -258,8 +258,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static doublecomplex c_b1 = {1.,0.}; @@ -273,7 +271,6 @@ h-Kaufman diagonal pivoting method (blocked algorithm, calling Level 3 BLAS). */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ZLAHEF + dependencies */ /* > */ @@ -284,7 +281,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -427,9 +423,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complex16HEcomputational */ +/* > \ingroup lahef */ /* > \par Contributors: */ /* ================== */ @@ -447,30 +441,25 @@ f"> */ integer *ldw, integer *info) { /* System generated locals */ - integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4; doublereal d__1, d__2, d__3, d__4; - doublecomplex z__1, z__2, z__3, z__4; + doublecomplex z__1, z__2, z__3, z__4, z__5; /* Local variables */ - integer imax, jmax, j, k; - doublereal t, alpha; + integer j, k; + doublereal t, r1; + doublecomplex d11, d21, d22; + integer jj, kk, jp, kp, kw, kkw, imax, jmax; + doublereal alpha; extern logical lsame_(char *, char *); - extern /* Subroutine */ void zgemm_(char *, char *, integer *, integer *, - integer *, doublecomplex *, doublecomplex *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *); integer kstep; extern /* Subroutine */ void zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, - integer *, doublecomplex *, doublecomplex *, integer *); - doublereal r1; - extern /* Subroutine */ void zcopy_(integer *, doublecomplex *, integer *, - doublecomplex *, integer *), zswap_(integer *, doublecomplex *, - integer *, doublecomplex *, integer *); - doublecomplex d11, d21, d22; - integer jb, jj, kk, jp, kp; + integer *, doublecomplex *, doublecomplex *, integer *), + zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, + integer *), zswap_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *); doublereal absakk; - integer kw; extern /* Subroutine */ void zdscal_(integer *, doublereal *, doublecomplex *, integer *); doublereal colmax; @@ -478,13 +467,15 @@ f"> */ ; extern integer izamax_(integer *, doublecomplex *, integer *); doublereal rowmax; - integer kkw; + extern /* Subroutine */ void zgemmtr_(char *, char *, char *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -492,11 +483,11 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; w_dim1 = *ldw; - w_offset = 1 + w_dim1 * 1; + w_offset = 1 + w_dim1; w -= w_offset; /* Function Body */ @@ -522,7 +513,7 @@ f"> */ /* Exit from loop */ - if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { goto L30; } @@ -538,7 +529,7 @@ f"> */ w[i__1].r = d__1, w[i__1].i = 0.; if (k < *n) { i__1 = *n - k; - z__1.r = -1., z__1.i = 0.; + z__1.r = -1., z__1.i = -0.; zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * w_dim1 + 1], &c__1); @@ -576,10 +567,7 @@ f"> */ *info = k; } kp = k; - i__1 = k + k * a_dim1; - i__2 = k + k * a_dim1; - d__1 = a[i__2].r; - a[i__1].r = d__1, a[i__1].i = 0.; + zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); } else { /* ============================================================ */ @@ -613,7 +601,7 @@ f"> */ zlacgv_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1); if (k < *n) { i__1 = *n - k; - z__1.r = -1., z__1.i = 0.; + z__1.r = -1., z__1.i = -0.; zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1); @@ -814,17 +802,17 @@ f"> */ /* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = */ /* ( ( -1 ) ( D22 ) ) */ -/* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = */ +/* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ), */ /* ( ( -1 ) ( D22 ) ) */ -/* = ( conj(D21)*( D11 ) D21*( -1 ) ) */ -/* ( ( -1 ) ( D22 ) ), */ - /* where D11 = d22/d21, */ /* D22 = d11/conj(d21), */ -/* D21 = T/d21, */ /* T = 1/(D22*D11-1). */ +/* T/d21 is not formed, since it overflows when d21 is */ +/* subnormal: each entry of the product is divided by */ +/* d21 or conj(d21) and then scaled by T. */ + /* (NOTE: No need to check for division by ZERO, */ /* since that was ensured earlier in pivot search: */ /* (a) d21 != 0, since in 2x2 pivot case(4) */ @@ -842,9 +830,6 @@ f"> */ z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r * d22.i + d11.i * d22.r; t = 1. / (z__1.r - 1.); - z__2.r = t, z__2.i = 0.; - z_div(&z__1, &z__2, &d21); - d21.r = z__1.r, d21.i = z__1.i; /* Update elements in columns A(k-1) and A(k) as */ /* dot products of rows of ( W(kw-1) W(kw) ) and columns */ @@ -854,17 +839,16 @@ f"> */ for (j = 1; j <= i__1; ++j) { i__2 = j + (k - 1) * a_dim1; i__3 = j + (kw - 1) * w_dim1; - z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i, - z__3.i = d11.r * w[i__3].i + d11.i * w[i__3] + z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] .r; i__4 = j + kw * w_dim1; - z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] .i; - z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = - d21.r * z__2.i + d21.i * z__2.r; + z_div(&z__2, &z__3, &d21); + z__1.r = t * z__2.r, z__1.i = t * z__2.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; i__2 = j + k * a_dim1; - d_cnjg(&z__2, &d21); i__3 = j + kw * w_dim1; z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] @@ -872,8 +856,9 @@ f"> */ i__4 = j + (kw - 1) * w_dim1; z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] .i; - z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = - z__2.r * z__3.i + z__2.i * z__3.r; + d_cnjg(&z__5, &d21); + z_div(&z__2, &z__3, &z__5); + z__1.r = t * z__2.r, z__1.i = t * z__2.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L20: */ } @@ -922,47 +907,13 @@ f"> */ /* A11 := A11 - U12*D*U12**H = A11 - U12*W**H */ -/* computing blocks of NB columns at a time (note that conjg(W) is */ -/* actually stored) */ - - i__1 = -(*nb); - for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += - i__1) { -/* Computing MIN */ - i__2 = *nb, i__3 = k - j + 1; - jb = f2cmin(i__2,i__3); - -/* Update the upper triangle of the diagonal block */ - - i__2 = j + jb - 1; - for (jj = j; jj <= i__2; ++jj) { - i__3 = jj + jj * a_dim1; - i__4 = jj + jj * a_dim1; - d__1 = a[i__4].r; - a[i__3].r = d__1, a[i__3].i = 0.; - i__3 = jj - j + 1; - i__4 = *n - k; - z__1.r = -1., z__1.i = 0.; - zgemv_("No transpose", &i__3, &i__4, &z__1, &a[j + (k + 1) * - a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1, - &a[j + jj * a_dim1], &c__1); - i__3 = jj + jj * a_dim1; - i__4 = jj + jj * a_dim1; - d__1 = a[i__4].r; - a[i__3].r = d__1, a[i__3].i = 0.; -/* L40: */ - } - -/* Update the rectangular superdiagonal block */ +/* (note that conjg(W) is actually stored) */ - i__2 = j - 1; - i__3 = *n - k; - z__1.r = -1., z__1.i = 0.; - zgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &z__1, &a[( - k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw, - &c_b1, &a[j * a_dim1 + 1], lda); -/* L50: */ - } + i__1 = *n - k; + z__1.r = -1., z__1.i = -0.; + zgemmtr_("Upper", "No transpose", "Transpose", &k, &i__1, &z__1, &a[( + k + 1) * a_dim1 + 1], lda, &w[(kw + 1) * w_dim1 + 1], ldw, & + c_b1, &a[a_dim1 + 1], lda); /* Put U12 in standard form by partially undoing the interchanges */ /* in columns k+1:n looping backwards from k+1 to n */ @@ -1009,7 +960,7 @@ f"> */ /* Exit from loop */ - if ((k >= *nb && *nb < *n) || k > *n) { + if (k >= *nb && *nb < *n || k > *n) { goto L90; } @@ -1028,7 +979,7 @@ f"> */ } i__1 = *n - k + 1; i__2 = k - 1; - z__1.r = -1., z__1.i = 0.; + z__1.r = -1., z__1.i = -0.; zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, &w[k + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1); i__1 = k + k * w_dim1; @@ -1064,10 +1015,9 @@ f"> */ *info = k; } kp = k; - i__1 = k + k * a_dim1; - i__2 = k + k * a_dim1; - d__1 = a[i__2].r; - a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); } else { /* ============================================================ */ @@ -1103,7 +1053,7 @@ f"> */ } i__1 = *n - k + 1; i__2 = k - 1; - z__1.r = -1., z__1.i = 0.; + z__1.r = -1., z__1.i = -0.; zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + 1) * w_dim1], &c__1); @@ -1299,17 +1249,17 @@ f"> */ /* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = */ /* ( ( -1 ) ( D22 ) ) */ -/* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = */ +/* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ), */ /* ( ( -1 ) ( D22 ) ) */ -/* = ( conj(D21)*( D11 ) D21*( -1 ) ) */ -/* ( ( -1 ) ( D22 ) ), */ - /* where D11 = d22/d21, */ /* D22 = d11/conj(d21), */ -/* D21 = T/d21, */ /* T = 1/(D22*D11-1). */ +/* T/d21 is not formed, since it overflows when d21 is */ +/* subnormal: each entry of the product is divided by */ +/* d21 or conj(d21) and then scaled by T. */ + /* (NOTE: No need to check for division by ZERO, */ /* since that was ensured earlier in pivot search: */ /* (a) d21 != 0, since in 2x2 pivot case(4) */ @@ -1327,9 +1277,6 @@ f"> */ z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r * d22.i + d11.i * d22.r; t = 1. / (z__1.r - 1.); - z__2.r = t, z__2.i = 0.; - z_div(&z__1, &z__2, &d21); - d21.r = z__1.r, d21.i = z__1.i; /* Update elements in columns A(k) and A(k+1) as */ /* dot products of rows of ( W(k) W(k+1) ) and columns */ @@ -1338,7 +1285,6 @@ f"> */ i__1 = *n; for (j = k + 2; j <= i__1; ++j) { i__2 = j + k * a_dim1; - d_cnjg(&z__2, &d21); i__3 = j + k * w_dim1; z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] @@ -1346,19 +1292,20 @@ f"> */ i__4 = j + (k + 1) * w_dim1; z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] .i; - z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = - z__2.r * z__3.i + z__2.i * z__3.r; + d_cnjg(&z__5, &d21); + z_div(&z__2, &z__3, &z__5); + z__1.r = t * z__2.r, z__1.i = t * z__2.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; i__2 = j + (k + 1) * a_dim1; i__3 = j + (k + 1) * w_dim1; - z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i, - z__3.i = d22.r * w[i__3].i + d22.i * w[i__3] + z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] .r; i__4 = j + k * w_dim1; - z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] .i; - z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = - d21.r * z__2.i + d21.i * z__2.r; + z_div(&z__2, &z__3, &d21); + z__1.r = t * z__2.r, z__1.i = t * z__2.i; a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L80: */ } @@ -1407,49 +1354,14 @@ f"> */ /* A22 := A22 - L21*D*L21**H = A22 - L21*W**H */ -/* computing blocks of NB columns at a time (note that conjg(W) is */ -/* actually stored) */ - - i__1 = *n; - i__2 = *nb; - for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { -/* Computing MIN */ - i__3 = *nb, i__4 = *n - j + 1; - jb = f2cmin(i__3,i__4); - -/* Update the lower triangle of the diagonal block */ - - i__3 = j + jb - 1; - for (jj = j; jj <= i__3; ++jj) { - i__4 = jj + jj * a_dim1; - i__5 = jj + jj * a_dim1; - d__1 = a[i__5].r; - a[i__4].r = d__1, a[i__4].i = 0.; - i__4 = j + jb - jj; - i__5 = k - 1; - z__1.r = -1., z__1.i = 0.; - zgemv_("No transpose", &i__4, &i__5, &z__1, &a[jj + a_dim1], - lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1] - , &c__1); - i__4 = jj + jj * a_dim1; - i__5 = jj + jj * a_dim1; - d__1 = a[i__5].r; - a[i__4].r = d__1, a[i__4].i = 0.; -/* L100: */ - } - -/* Update the rectangular subdiagonal block */ +/* (note that conjg(W) is actually stored) */ - if (j + jb <= *n) { - i__3 = *n - j - jb + 1; - i__4 = k - 1; - z__1.r = -1., z__1.i = 0.; - zgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &z__1, - &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1, - &a[j + jb + j * a_dim1], lda); - } -/* L110: */ - } + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = -0.; + zgemmtr_("Lower", "No transpose", "Transpose", &i__1, &i__2, &z__1, & + a[k + a_dim1], lda, &w[k + w_dim1], ldw, &c_b1, &a[k + k * + a_dim1], lda); /* Put L21 in standard form by partially undoing the interchanges */ /* of rows in columns 1:k-1 looping backwards from k-1 to 1 */ diff --git a/lapack-netlib/SRC/zlahef.f b/lapack-netlib/SRC/zlahef.f index 22a638ba82..fc2b3a96e0 100644 --- a/lapack-netlib/SRC/zlahef.f +++ b/lapack-netlib/SRC/zlahef.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZLAHEF + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -160,7 +158,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16HEcomputational +*> \ingroup lahef * *> \par Contributors: * ================== @@ -173,7 +171,9 @@ *> \endverbatim * * ===================================================================== - SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) + SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, + $ INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -199,7 +199,7 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) * .. * .. Local Scalars .. - INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP, + INTEGER IMAX, J, JJ, JMAX, JP, K, KK, KKW, KP, $ KSTEP, KW DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, R1, ROWMAX, T COMPLEX*16 D11, D21, D22, Z @@ -210,7 +210,8 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) EXTERNAL LSAME, IZAMAX * .. * .. External Subroutines .. - EXTERNAL ZCOPY, ZDSCAL, ZGEMM, ZGEMV, ZLACGV, ZSWAP + EXTERNAL ZCOPY, ZDSCAL, ZGEMMTR, ZGEMV, ZLACGV, + $ ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT @@ -255,7 +256,8 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) CALL ZCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 ) W( K, KW ) = DBLE( A( K, K ) ) IF( K.LT.N ) THEN - CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA, + CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), + $ LDA, $ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 ) W( K, KW ) = DBLE( W( K, KW ) ) END IF @@ -283,7 +285,7 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) IF( INFO.EQ.0 ) $ INFO = K KP = K - A( K, K ) = DBLE( A( K, K ) ) + CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) ELSE * * ============================================================ @@ -478,17 +480,17 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = * ( ( -1 ) ( D22 ) ) * -* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ), * ( ( -1 ) ( D22 ) ) * -* = ( conj(D21)*( D11 ) D21*( -1 ) ) -* ( ( -1 ) ( D22 ) ), -* * where D11 = d22/d21, * D22 = d11/conj(d21), -* D21 = T/d21, * T = 1/(D22*D11-1). * +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 or conj(d21) and then scaled by T. +* * (NOTE: No need to check for division by ZERO, * since that was ensured earlier in pivot search: * (a) d21 != 0, since in 2x2 pivot case(4) @@ -500,16 +502,16 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) D11 = W( K, KW ) / DCONJG( D21 ) D22 = W( K-1, KW-1 ) / D21 T = ONE / ( DBLE( D11*D22 )-ONE ) - D21 = T / D21 * * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) * DO 20 J = 1, K - 2 - A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) - A( J, K ) = DCONJG( D21 )* - $ ( D22*W( J, KW )-W( J, KW-1 ) ) + A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ DCONJG( D21 ) ) 20 CONTINUE END IF * @@ -548,28 +550,11 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * A11 := A11 - U12*D*U12**H = A11 - U12*W**H * -* computing blocks of NB columns at a time (note that conjg(W) is -* actually stored) -* - DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB - JB = MIN( NB, K-J+1 ) -* -* Update the upper triangle of the diagonal block +* (note that conjg(W) is actually stored) * - DO 40 JJ = J, J + JB - 1 - A( JJ, JJ ) = DBLE( A( JJ, JJ ) ) - CALL ZGEMV( 'No transpose', JJ-J+1, N-K, -CONE, - $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE, - $ A( J, JJ ), 1 ) - A( JJ, JJ ) = DBLE( A( JJ, JJ ) ) - 40 CONTINUE -* -* Update the rectangular superdiagonal block -* - CALL ZGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, - $ -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, - $ CONE, A( 1, J ), LDA ) - 50 CONTINUE + CALL ZGEMMTR( 'Upper', 'No transpose', 'Transpose', K, N-K, + $ -CONE, A( 1, K+1 ), LDA, W( 1, KW+1 ), LDW, + $ CONE, A( 1, 1 ), LDA ) * * Put U12 in standard form by partially undoing the interchanges * in columns k+1:n looping backwards from k+1 to n @@ -623,7 +608,8 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) W( K, K ) = DBLE( A( K, K ) ) IF( K.LT.N ) $ CALL ZCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 ) - CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), LDA, + CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), + $ LDA, $ W( K, 1 ), LDW, CONE, W( K, K ), 1 ) W( K, K ) = DBLE( W( K, K ) ) * @@ -650,7 +636,7 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) IF( INFO.EQ.0 ) $ INFO = K KP = K - A( K, K ) = DBLE( A( K, K ) ) + CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) ELSE * * ============================================================ @@ -670,13 +656,15 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * Copy column IMAX to column K+1 of W and update it * - CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 ) + CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), + $ 1 ) CALL ZLACGV( IMAX-K, W( K, K+1 ), 1 ) W( IMAX, K+1 ) = DBLE( A( IMAX, IMAX ) ) IF( IMAX.LT.N ) $ CALL ZCOPY( N-IMAX, A( IMAX+1, IMAX ), 1, $ W( IMAX+1, K+1 ), 1 ) - CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), + CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, + $ 1 ), $ LDA, W( IMAX, 1 ), LDW, CONE, W( K, K+1 ), $ 1 ) W( IMAX, K+1 ) = DBLE( W( IMAX, K+1 ) ) @@ -750,7 +738,8 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) $ LDA ) CALL ZLACGV( KP-KK-1, A( KP, KK+1 ), LDA ) IF( KP.LT.N ) - $ CALL ZCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL ZCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) * * Interchange rows KK and KP in first K-1 columns of A * (columns K (or K and K+1 for 2-by-2 pivot) of A will be @@ -838,17 +827,17 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = * ( ( -1 ) ( D22 ) ) * -* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ), * ( ( -1 ) ( D22 ) ) * -* = ( conj(D21)*( D11 ) D21*( -1 ) ) -* ( ( -1 ) ( D22 ) ), -* * where D11 = d22/d21, * D22 = d11/conj(d21), -* D21 = T/d21, * T = 1/(D22*D11-1). * +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 or conj(d21) and then scaled by T. +* * (NOTE: No need to check for division by ZERO, * since that was ensured earlier in pivot search: * (a) d21 != 0, since in 2x2 pivot case(4) @@ -860,16 +849,16 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / DCONJG( D21 ) T = ONE / ( DBLE( D11*D22 )-ONE ) - D21 = T / D21 * * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) * DO 80 J = K + 2, N - A( J, K ) = DCONJG( D21 )* - $ ( D11*W( J, K )-W( J, K+1 ) ) - A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ DCONJG( D21 ) ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * @@ -908,29 +897,11 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * A22 := A22 - L21*D*L21**H = A22 - L21*W**H * -* computing blocks of NB columns at a time (note that conjg(W) is -* actually stored) -* - DO 110 J = K, N, NB - JB = MIN( NB, N-J+1 ) -* -* Update the lower triangle of the diagonal block -* - DO 100 JJ = J, J + JB - 1 - A( JJ, JJ ) = DBLE( A( JJ, JJ ) ) - CALL ZGEMV( 'No transpose', J+JB-JJ, K-1, -CONE, - $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE, - $ A( JJ, JJ ), 1 ) - A( JJ, JJ ) = DBLE( A( JJ, JJ ) ) - 100 CONTINUE -* -* Update the rectangular subdiagonal block +* (note that conjg(W) is actually stored) * - IF( J+JB.LE.N ) - $ CALL ZGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, - $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ), - $ LDW, CONE, A( J+JB, J ), LDA ) - 110 CONTINUE + CALL ZGEMMTR( 'Lower', 'No transpose', 'Transpose', N-K+1, + $ K-1, -CONE, A( K, 1 ), LDA, W( K, 1 ), LDW, + $ CONE, A( K, K ), LDA ) * * Put L21 in standard form by partially undoing the interchanges * of rows in columns 1:k-1 looping backwards from k-1 to 1 diff --git a/lapack-netlib/SRC/zlasyf.c b/lapack-netlib/SRC/zlasyf.c index e0e4b6a430..7efc6c075f 100644 --- a/lapack-netlib/SRC/zlasyf.c +++ b/lapack-netlib/SRC/zlasyf.c @@ -258,8 +258,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static doublecomplex c_b1 = {1.,0.}; @@ -273,7 +271,6 @@ iagonal pivoting method. */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ZLASYF + dependencies */ /* > */ @@ -284,7 +281,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -427,9 +423,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date November 2013 */ - -/* > \ingroup complex16SYcomputational */ +/* > \ingroup lahef */ /* > \par Contributors: */ /* ================== */ @@ -447,42 +441,37 @@ f"> */ integer *ldw, integer *info) { /* System generated locals */ - integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4; doublereal d__1, d__2, d__3, d__4; - doublecomplex z__1, z__2, z__3; + doublecomplex z__1, z__2, z__3, z__4; /* Local variables */ - integer imax, jmax, j, k; - doublecomplex t; + integer j, k; + doublecomplex t, r1, d11, d21, d22; + integer jj, kk, jp, kp, kw, kkw, imax, jmax; doublereal alpha; extern logical lsame_(char *, char *); extern /* Subroutine */ void zscal_(integer *, doublecomplex *, - doublecomplex *, integer *), zgemm_(char *, char *, integer *, - integer *, integer *, doublecomplex *, doublecomplex *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *); + doublecomplex *, integer *); integer kstep; extern /* Subroutine */ void zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, - integer *, doublecomplex *, doublecomplex *, integer *); - doublecomplex r1; - extern /* Subroutine */ void zcopy_(integer *, doublecomplex *, integer *, - doublecomplex *, integer *), zswap_(integer *, doublecomplex *, - integer *, doublecomplex *, integer *); - doublecomplex d11, d21, d22; - integer jb, jj, kk, jp, kp; - doublereal absakk; - integer kw; - doublereal colmax; + integer *, doublecomplex *, doublecomplex *, integer *), + zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, + integer *), zswap_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + doublereal absakk, colmax; extern integer izamax_(integer *, doublecomplex *, integer *); doublereal rowmax; - integer kkw; + extern /* Subroutine */ void zgemmtr_(char *, char *, char *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); -/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* November 2013 */ /* ===================================================================== */ @@ -490,11 +479,11 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; w_dim1 = *ldw; - w_offset = 1 + w_dim1 * 1; + w_offset = 1 + w_dim1; w -= w_offset; /* Function Body */ @@ -520,7 +509,7 @@ f"> */ /* Exit from loop */ - if ((k <= *n - *nb + 1 && *nb < *n) || k < 1) { + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { goto L30; } @@ -529,7 +518,7 @@ f"> */ zcopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); if (k < *n) { i__1 = *n - k; - z__1.r = -1., z__1.i = 0.; + z__1.r = -1., z__1.i = -0.; zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * w_dim1 + 1], &c__1); @@ -564,6 +553,7 @@ f"> */ *info = k; } kp = k; + zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); } else { if (absakk >= alpha * colmax) { @@ -581,7 +571,7 @@ f"> */ 1 + (kw - 1) * w_dim1], &c__1); if (k < *n) { i__1 = *n - k; - z__1.r = -1., z__1.i = 0.; + z__1.r = -1., z__1.i = -0.; zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1); @@ -748,8 +738,9 @@ f"> */ /* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */ /* ( ( -1 ) ( D22 ) ) */ -/* = D21 * ( ( D11 ) ( -1 ) ) */ -/* ( ( -1 ) ( D22 ) ) */ +/* T/d21 is not formed, since it overflows when d21 is */ +/* subnormal: each entry of the product is divided by */ +/* d21 and then scaled by T. */ i__1 = k - 1 + kw * w_dim1; d21.r = w[i__1].r, d21.i = w[i__1].i; @@ -759,11 +750,9 @@ f"> */ d22.r = z__1.r, d22.i = z__1.i; z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * d22.i + d11.i * d22.r; - z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; + z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.; z_div(&z__1, &c_b1, &z__2); t.r = z__1.r, t.i = z__1.i; - z_div(&z__1, &t, &d21); - d21.r = z__1.r, d21.i = z__1.i; /* Update elements in columns A(k-1) and A(k) as */ /* dot products of rows of ( W(kw-1) W(kw) ) and columns */ @@ -773,25 +762,27 @@ f"> */ for (j = 1; j <= i__1; ++j) { i__2 = j + (k - 1) * a_dim1; i__3 = j + (kw - 1) * w_dim1; - z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i, - z__3.i = d11.r * w[i__3].i + d11.i * w[i__3] + z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] .r; i__4 = j + kw * w_dim1; - z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] .i; - z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = - d21.r * z__2.i + d21.i * z__2.r; + z_div(&z__2, &z__3, &d21); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; a[i__2].r = z__1.r, a[i__2].i = z__1.i; i__2 = j + k * a_dim1; i__3 = j + kw * w_dim1; - z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i, - z__3.i = d22.r * w[i__3].i + d22.i * w[i__3] + z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] .r; i__4 = j + (kw - 1) * w_dim1; - z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] .i; - z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = - d21.r * z__2.i + d21.i * z__2.r; + z_div(&z__2, &z__3, &d21); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L20: */ } @@ -833,38 +824,11 @@ f"> */ /* A11 := A11 - U12*D*U12**T = A11 - U12*W**T */ -/* computing blocks of NB columns at a time */ - - i__1 = -(*nb); - for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += - i__1) { -/* Computing MIN */ - i__2 = *nb, i__3 = k - j + 1; - jb = f2cmin(i__2,i__3); - -/* Update the upper triangle of the diagonal block */ - - i__2 = j + jb - 1; - for (jj = j; jj <= i__2; ++jj) { - i__3 = jj - j + 1; - i__4 = *n - k; - z__1.r = -1., z__1.i = 0.; - zgemv_("No transpose", &i__3, &i__4, &z__1, &a[j + (k + 1) * - a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1, - &a[j + jj * a_dim1], &c__1); -/* L40: */ - } - -/* Update the rectangular superdiagonal block */ - - i__2 = j - 1; - i__3 = *n - k; - z__1.r = -1., z__1.i = 0.; - zgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &z__1, &a[( - k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw, - &c_b1, &a[j * a_dim1 + 1], lda); -/* L50: */ - } + i__1 = *n - k; + z__1.r = -1., z__1.i = -0.; + zgemmtr_("Upper", "No transpose", "Transpose", &k, &i__1, &z__1, &a[( + k + 1) * a_dim1 + 1], lda, &w[(kw + 1) * w_dim1 + 1], ldw, & + c_b1, &a[a_dim1 + 1], lda); /* Put U12 in standard form by partially undoing the interchanges */ /* in columns k+1:n looping backwards from k+1 to n */ @@ -911,7 +875,7 @@ f"> */ /* Exit from loop */ - if ((k >= *nb && *nb < *n) || k > *n) { + if (k >= *nb && *nb < *n || k > *n) { goto L90; } @@ -921,7 +885,7 @@ f"> */ zcopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); i__1 = *n - k + 1; i__2 = k - 1; - z__1.r = -1., z__1.i = 0.; + z__1.r = -1., z__1.i = -0.; zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, &w[k + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1); @@ -954,6 +918,9 @@ f"> */ *info = k; } kp = k; + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); } else { if (absakk >= alpha * colmax) { @@ -972,7 +939,7 @@ f"> */ 1) * w_dim1], &c__1); i__1 = *n - k + 1; i__2 = k - 1; - z__1.r = -1., z__1.i = 0.; + z__1.r = -1., z__1.i = -0.; zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + 1) * w_dim1], &c__1); @@ -1136,8 +1103,9 @@ f"> */ /* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */ /* ( ( -1 ) ( D22 ) ) */ -/* = D21 * ( ( D11 ) ( -1 ) ) */ -/* ( ( -1 ) ( D22 ) ) */ +/* T/d21 is not formed, since it overflows when d21 is */ +/* subnormal: each entry of the product is divided by */ +/* d21 and then scaled by T. */ i__1 = k + 1 + k * w_dim1; d21.r = w[i__1].r, d21.i = w[i__1].i; @@ -1147,11 +1115,9 @@ f"> */ d22.r = z__1.r, d22.i = z__1.i; z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * d22.i + d11.i * d22.r; - z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; + z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.; z_div(&z__1, &c_b1, &z__2); t.r = z__1.r, t.i = z__1.i; - z_div(&z__1, &t, &d21); - d21.r = z__1.r, d21.i = z__1.i; /* Update elements in columns A(k) and A(k+1) as */ /* dot products of rows of ( W(k) W(k+1) ) and columns */ @@ -1161,25 +1127,27 @@ f"> */ for (j = k + 2; j <= i__1; ++j) { i__2 = j + k * a_dim1; i__3 = j + k * w_dim1; - z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i, - z__3.i = d11.r * w[i__3].i + d11.i * w[i__3] + z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] .r; i__4 = j + (k + 1) * w_dim1; - z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] .i; - z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = - d21.r * z__2.i + d21.i * z__2.r; + z_div(&z__2, &z__3, &d21); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; a[i__2].r = z__1.r, a[i__2].i = z__1.i; i__2 = j + (k + 1) * a_dim1; i__3 = j + (k + 1) * w_dim1; - z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i, - z__3.i = d22.r * w[i__3].i + d22.i * w[i__3] + z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] .r; i__4 = j + k * w_dim1; - z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] .i; - z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = - d21.r * z__2.i + d21.i * z__2.r; + z_div(&z__2, &z__3, &d21); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; a[i__2].r = z__1.r, a[i__2].i = z__1.i; /* L80: */ } @@ -1221,40 +1189,12 @@ f"> */ /* A22 := A22 - L21*D*L21**T = A22 - L21*W**T */ -/* computing blocks of NB columns at a time */ - - i__1 = *n; - i__2 = *nb; - for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { -/* Computing MIN */ - i__3 = *nb, i__4 = *n - j + 1; - jb = f2cmin(i__3,i__4); - -/* Update the lower triangle of the diagonal block */ - - i__3 = j + jb - 1; - for (jj = j; jj <= i__3; ++jj) { - i__4 = j + jb - jj; - i__5 = k - 1; - z__1.r = -1., z__1.i = 0.; - zgemv_("No transpose", &i__4, &i__5, &z__1, &a[jj + a_dim1], - lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1] - , &c__1); -/* L100: */ - } - -/* Update the rectangular subdiagonal block */ - - if (j + jb <= *n) { - i__3 = *n - j - jb + 1; - i__4 = k - 1; - z__1.r = -1., z__1.i = 0.; - zgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &z__1, - &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1, - &a[j + jb + j * a_dim1], lda); - } -/* L110: */ - } + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = -0.; + zgemmtr_("Lower", "No transpose", "Transpose", &i__1, &i__2, &z__1, & + a[k + a_dim1], lda, &w[k + w_dim1], ldw, &c_b1, &a[k + k * + a_dim1], lda); /* Put L21 in standard form by partially undoing the interchanges */ /* of rows in columns 1:k-1 looping backwards from k-1 to 1 */ diff --git a/lapack-netlib/SRC/zlasyf.f b/lapack-netlib/SRC/zlasyf.f index 57f236d1bd..0e1eec20c2 100644 --- a/lapack-netlib/SRC/zlasyf.f +++ b/lapack-netlib/SRC/zlasyf.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZLASYF + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -160,7 +158,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16SYcomputational +*> \ingroup lahef * *> \par Contributors: * ================== @@ -173,7 +171,9 @@ *> \endverbatim * * ===================================================================== - SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) + SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, + $ INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -199,7 +199,7 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. - INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP, + INTEGER IMAX, J, JJ, JMAX, JP, K, KK, KKW, KP, $ KSTEP, KW DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX COMPLEX*16 D11, D21, D22, R1, T, Z @@ -210,7 +210,7 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) EXTERNAL LSAME, IZAMAX * .. * .. External Subroutines .. - EXTERNAL ZCOPY, ZGEMM, ZGEMV, ZSCAL, ZSWAP + EXTERNAL ZCOPY, ZGEMMTR, ZGEMV, ZSCAL, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX, MIN, SQRT @@ -252,7 +252,8 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * CALL ZCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) IF( K.LT.N ) - $ CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA, + $ CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), + $ LDA, $ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 ) * KSTEP = 1 @@ -279,6 +280,7 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * @@ -430,22 +432,24 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* = D21 * ( ( D11 ) ( -1 ) ) -* ( ( -1 ) ( D22 ) ) +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 D22 = W( K-1, KW-1 ) / D21 T = CONE / ( D11*D22-CONE ) - D21 = T / D21 * * Update elements in columns A(k-1) and A(k) as * dot products of rows of ( W(kw-1) W(kw) ) and columns * of D**(-1) * DO 20 J = 1, K - 2 - A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) - A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D21 ) 20 CONTINUE END IF * @@ -479,25 +483,9 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * A11 := A11 - U12*D*U12**T = A11 - U12*W**T * -* computing blocks of NB columns at a time -* - DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB - JB = MIN( NB, K-J+1 ) -* -* Update the upper triangle of the diagonal block -* - DO 40 JJ = J, J + JB - 1 - CALL ZGEMV( 'No transpose', JJ-J+1, N-K, -CONE, - $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE, - $ A( J, JJ ), 1 ) - 40 CONTINUE -* -* Update the rectangular superdiagonal block -* - CALL ZGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, - $ -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, - $ CONE, A( 1, J ), LDA ) - 50 CONTINUE + CALL ZGEMMTR( 'Upper', 'No transpose', 'Transpose', K, N-K, + $ -CONE, A( 1, K+1 ), LDA, W( 1, KW+1 ), LDW, + $ CONE, A( 1, 1 ), LDA ) * * Put U12 in standard form by partially undoing the interchanges * in columns k+1:n looping backwards from k+1 to n @@ -547,7 +535,8 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * Copy column K of A to column K of W and update it * CALL ZCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) - CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), LDA, + CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), + $ LDA, $ W( K, 1 ), LDW, CONE, W( K, K ), 1 ) * KSTEP = 1 @@ -574,6 +563,7 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * @@ -584,10 +574,13 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * Copy column IMAX to column K+1 of W and update it * - CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 ) - CALL ZCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ), + CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), + $ 1 ) + CALL ZCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, + $ K+1 ), $ 1 ) - CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), + CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, + $ 1 ), $ LDA, W( IMAX, 1 ), LDW, CONE, W( K, K+1 ), $ 1 ) * @@ -646,7 +639,8 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) CALL ZCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), $ LDA ) IF( KP.LT.N ) - $ CALL ZCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL ZCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) * * Interchange rows KK and KP in first K-1 columns of A * (columns K (or K and K+1 for 2-by-2 pivot) of A will be @@ -720,22 +714,24 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * = 1/d21 * T * ( ( D11 ) ( -1 ) ) * ( ( -1 ) ( D22 ) ) * -* = D21 * ( ( D11 ) ( -1 ) ) -* ( ( -1 ) ( D22 ) ) +* T/d21 is not formed, since it overflows when d21 is +* subnormal: each entry of the product is divided by +* d21 and then scaled by T. * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = CONE / ( D11*D22-CONE ) - D21 = T / D21 * * Update elements in columns A(k) and A(k+1) as * dot products of rows of ( W(k) W(k+1) ) and columns * of D**(-1) * DO 80 J = K + 2, N - A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) - A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) 80 CONTINUE END IF * @@ -769,26 +765,9 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * A22 := A22 - L21*D*L21**T = A22 - L21*W**T * -* computing blocks of NB columns at a time -* - DO 110 J = K, N, NB - JB = MIN( NB, N-J+1 ) -* -* Update the lower triangle of the diagonal block -* - DO 100 JJ = J, J + JB - 1 - CALL ZGEMV( 'No transpose', J+JB-JJ, K-1, -CONE, - $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE, - $ A( JJ, JJ ), 1 ) - 100 CONTINUE -* -* Update the rectangular subdiagonal block -* - IF( J+JB.LE.N ) - $ CALL ZGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, - $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ), - $ LDW, CONE, A( J+JB, J ), LDA ) - 110 CONTINUE + CALL ZGEMMTR( 'Lower', 'No transpose', 'Transpose', N-K+1, + $ K-1, -CONE, A( K, 1 ), LDA, W( K, 1 ), LDW, + $ CONE, A( K, K ), LDA ) * * Put L21 in standard form by partially undoing the interchanges * of rows in columns 1:k-1 looping backwards from k-1 to 1 diff --git a/lapack-netlib/SRC/zsptrf.c b/lapack-netlib/SRC/zsptrf.c index 47b819822f..9f287a28ec 100644 --- a/lapack-netlib/SRC/zsptrf.c +++ b/lapack-netlib/SRC/zsptrf.c @@ -246,11 +246,11 @@ typedef struct Namelist Namelist; #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; -#define mycycle_() continue; -#define myceiling_(w) {ceil(w)} -#define myhuge_(w) {HUGE_VAL} +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} -#define mymaxloc_(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} /* -- translated by f2c (version 20000121). You must link the resulting object file with the libraries: @@ -258,8 +258,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static doublecomplex c_b1 = {1.,0.}; @@ -272,7 +270,6 @@ static integer c__1 = 1; /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ZSPTRF + dependencies */ /* > */ @@ -283,7 +280,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -374,9 +370,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complex16OTHERcomputational */ +/* > \ingroup hptrf */ /* > \par Further Details: */ /* ===================== */ @@ -431,37 +425,34 @@ f"> */ doublecomplex z__1, z__2, z__3, z__4; /* Local variables */ + integer i__, j, k; + doublecomplex t, r1, d11, d12, d21, d22; + integer kc, kk, kp; + doublecomplex wk; + integer kx, knc, kpc, npp; + doublecomplex wkm1, wkp1; integer imax, jmax; extern /* Subroutine */ void zspr_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *); - integer i__, j, k; - doublecomplex t; doublereal alpha; extern logical lsame_(char *, char *); extern /* Subroutine */ void zscal_(integer *, doublecomplex *, doublecomplex *, integer *); integer kstep; logical upper; - doublecomplex r1; extern /* Subroutine */ void zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); - doublecomplex d11, d12, d21, d22; - integer kc, kk, kp; doublereal absakk; - doublecomplex wk; - integer kx; + extern logical disnan_(doublereal *); extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); doublereal colmax; extern integer izamax_(integer *, doublecomplex *, integer *); doublereal rowmax; - integer knc, kpc, npp; - doublecomplex wkm1, wkp1; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -530,9 +521,10 @@ f"> */ colmax = 0.; } - if (f2cmax(absakk,colmax) == 0.) { + if (f2cmax(absakk,colmax) == 0. || disnan_(&absakk)) { -/* Column K is zero: set INFO and continue */ +/* Column K is zero or underflow, or contains a NaN: */ +/* set INFO and continue */ if (*info == 0) { *info = k; @@ -688,32 +680,32 @@ f"> */ d11.r = z__1.r, d11.i = z__1.i; z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * d22.i + d11.i * d22.r; - z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; + z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.; z_div(&z__1, &c_b1, &z__2); t.r = z__1.r, t.i = z__1.i; - z_div(&z__1, &t, &d12); - d12.r = z__1.r, d12.i = z__1.i; for (j = k - 2; j >= 1; --j) { i__1 = j + (k - 2) * (k - 1) / 2; - z__3.r = d11.r * ap[i__1].r - d11.i * ap[i__1].i, - z__3.i = d11.r * ap[i__1].i + d11.i * ap[i__1] + z__4.r = d11.r * ap[i__1].r - d11.i * ap[i__1].i, + z__4.i = d11.r * ap[i__1].i + d11.i * ap[i__1] .r; i__2 = j + (k - 1) * k / 2; - z__2.r = z__3.r - ap[i__2].r, z__2.i = z__3.i - ap[ + z__3.r = z__4.r - ap[i__2].r, z__3.i = z__4.i - ap[ i__2].i; - z__1.r = d12.r * z__2.r - d12.i * z__2.i, z__1.i = - d12.r * z__2.i + d12.i * z__2.r; + z_div(&z__2, &z__3, &d12); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; wkm1.r = z__1.r, wkm1.i = z__1.i; i__1 = j + (k - 1) * k / 2; - z__3.r = d22.r * ap[i__1].r - d22.i * ap[i__1].i, - z__3.i = d22.r * ap[i__1].i + d22.i * ap[i__1] + z__4.r = d22.r * ap[i__1].r - d22.i * ap[i__1].i, + z__4.i = d22.r * ap[i__1].i + d22.i * ap[i__1] .r; i__2 = j + (k - 2) * (k - 1) / 2; - z__2.r = z__3.r - ap[i__2].r, z__2.i = z__3.i - ap[ + z__3.r = z__4.r - ap[i__2].r, z__3.i = z__4.i - ap[ i__2].i; - z__1.r = d12.r * z__2.r - d12.i * z__2.i, z__1.i = - d12.r * z__2.i + d12.i * z__2.r; + z_div(&z__2, &z__3, &d12); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; wk.r = z__1.r, wk.i = z__1.i; for (i__ = j; i__ >= 1; --i__) { i__1 = i__ + (j - 1) * j / 2; @@ -799,9 +791,10 @@ f"> */ colmax = 0.; } - if (f2cmax(absakk,colmax) == 0.) { + if (f2cmax(absakk,colmax) == 0. || disnan_(&absakk)) { -/* Column K is zero: set INFO and continue */ +/* Column K is zero or underflow, or contains a NaN: */ +/* set INFO and continue */ if (*info == 0) { *info = k; @@ -971,33 +964,33 @@ f"> */ d22.r = z__1.r, d22.i = z__1.i; z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * d22.i + d11.i * d22.r; - z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; + z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.; z_div(&z__1, &c_b1, &z__2); t.r = z__1.r, t.i = z__1.i; - z_div(&z__1, &t, &d21); - d21.r = z__1.r, d21.i = z__1.i; i__1 = *n; for (j = k + 2; j <= i__1; ++j) { i__2 = j + (k - 1) * ((*n << 1) - k) / 2; - z__3.r = d11.r * ap[i__2].r - d11.i * ap[i__2].i, - z__3.i = d11.r * ap[i__2].i + d11.i * ap[i__2] + z__4.r = d11.r * ap[i__2].r - d11.i * ap[i__2].i, + z__4.i = d11.r * ap[i__2].i + d11.i * ap[i__2] .r; i__3 = j + k * ((*n << 1) - k - 1) / 2; - z__2.r = z__3.r - ap[i__3].r, z__2.i = z__3.i - ap[ + z__3.r = z__4.r - ap[i__3].r, z__3.i = z__4.i - ap[ i__3].i; - z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = - d21.r * z__2.i + d21.i * z__2.r; + z_div(&z__2, &z__3, &d21); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; wk.r = z__1.r, wk.i = z__1.i; i__2 = j + k * ((*n << 1) - k - 1) / 2; - z__3.r = d22.r * ap[i__2].r - d22.i * ap[i__2].i, - z__3.i = d22.r * ap[i__2].i + d22.i * ap[i__2] + z__4.r = d22.r * ap[i__2].r - d22.i * ap[i__2].i, + z__4.i = d22.r * ap[i__2].i + d22.i * ap[i__2] .r; i__3 = j + (k - 1) * ((*n << 1) - k) / 2; - z__2.r = z__3.r - ap[i__3].r, z__2.i = z__3.i - ap[ + z__3.r = z__4.r - ap[i__3].r, z__3.i = z__4.i - ap[ i__3].i; - z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = - d21.r * z__2.i + d21.i * z__2.r; + z_div(&z__2, &z__3, &d21); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; wkp1.r = z__1.r, wkp1.i = z__1.i; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { diff --git a/lapack-netlib/SRC/zsptrf.f b/lapack-netlib/SRC/zsptrf.f index 4a5a7a50b8..42a916cdbd 100644 --- a/lapack-netlib/SRC/zsptrf.f +++ b/lapack-netlib/SRC/zsptrf.f @@ -375,13 +375,12 @@ SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO ) D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12 D11 = AP( K+( K-1 )*K / 2 ) / D12 T = CONE / ( D11*D22-CONE ) - D12 = T / D12 * DO 50 J = K - 2, 1, -1 - WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ AP( J+( K-1 )*K / 2 ) ) - WK = D12*( D22*AP( J+( K-1 )*K / 2 )- - $ AP( J+( K-2 )*( K-1 ) / 2 ) ) + WKM1 = T*( ( D11*AP( J+( K-2 )*( K-1 ) / 2 )- + $ AP( J+( K-1 )*K / 2 ) ) / D12 ) + WK = T*( ( D22*AP( J+( K-1 )*K / 2 )- + $ AP( J+( K-2 )*( K-1 ) / 2 ) ) / D12 ) DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*WK - @@ -576,13 +575,12 @@ SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO ) D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 T = CONE / ( D11*D22-CONE ) - D21 = T / D21 * DO 100 J = K + 2, N - WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- - $ AP( J+K*( 2*N-K-1 ) / 2 ) ) - WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- - $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) + WK = T*( ( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- + $ AP( J+K*( 2*N-K-1 ) / 2 ) ) / D21 ) + WKP1 = T*( ( D22*AP( J+K*( 2*N-K-1 ) / 2 )- + $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) / D21 ) DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / diff --git a/lapack-netlib/SRC/zsytf2.c b/lapack-netlib/SRC/zsytf2.c index 38e8e8e939..be1e3f7e86 100644 --- a/lapack-netlib/SRC/zsytf2.c +++ b/lapack-netlib/SRC/zsytf2.c @@ -246,11 +246,11 @@ typedef struct Namelist Namelist; #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; -#define mycycle_() continue; -#define myceiling_(w) {ceil(w)} -#define myhuge_(w) {HUGE_VAL} +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} -#define mymaxloc_(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} /* -- translated by f2c (version 20000121). You must link the resulting object file with the libraries: @@ -258,8 +258,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static doublecomplex c_b1 = {1.,0.}; @@ -273,7 +271,6 @@ oting method (unblocked algorithm). */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ZSYTF2 + dependencies */ /* > */ @@ -284,7 +281,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -394,9 +390,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complex16SYcomputational */ +/* > \ingroup hetf2 */ /* > \par Further Details: */ /* ===================== */ @@ -465,36 +459,32 @@ f"> */ doublecomplex z__1, z__2, z__3, z__4; /* Local variables */ + integer i__, j, k; + doublecomplex t, r1, d11, d12, d21, d22; + integer kk, kp; + doublecomplex wk, wkm1, wkp1; integer imax, jmax; extern /* Subroutine */ void zsyr_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *); - integer i__, j, k; - doublecomplex t; doublereal alpha; extern logical lsame_(char *, char *); extern /* Subroutine */ void zscal_(integer *, doublecomplex *, doublecomplex *, integer *); integer kstep; logical upper; - doublecomplex r1; extern /* Subroutine */ void zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); - doublecomplex d11, d12, d21, d22; - integer kk, kp; doublereal absakk; - doublecomplex wk; extern logical disnan_(doublereal *); extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); doublereal colmax; extern integer izamax_(integer *, doublecomplex *, integer *); doublereal rowmax; - doublecomplex wkm1, wkp1; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -504,7 +494,7 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; @@ -708,32 +698,32 @@ f"> */ d11.r = z__1.r, d11.i = z__1.i; z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * d22.i + d11.i * d22.r; - z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; + z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.; z_div(&z__1, &c_b1, &z__2); t.r = z__1.r, t.i = z__1.i; - z_div(&z__1, &t, &d12); - d12.r = z__1.r, d12.i = z__1.i; for (j = k - 2; j >= 1; --j) { i__1 = j + (k - 1) * a_dim1; - z__3.r = d11.r * a[i__1].r - d11.i * a[i__1].i, - z__3.i = d11.r * a[i__1].i + d11.i * a[i__1] + z__4.r = d11.r * a[i__1].r - d11.i * a[i__1].i, + z__4.i = d11.r * a[i__1].i + d11.i * a[i__1] .r; i__2 = j + k * a_dim1; - z__2.r = z__3.r - a[i__2].r, z__2.i = z__3.i - a[i__2] + z__3.r = z__4.r - a[i__2].r, z__3.i = z__4.i - a[i__2] .i; - z__1.r = d12.r * z__2.r - d12.i * z__2.i, z__1.i = - d12.r * z__2.i + d12.i * z__2.r; + z_div(&z__2, &z__3, &d12); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; wkm1.r = z__1.r, wkm1.i = z__1.i; i__1 = j + k * a_dim1; - z__3.r = d22.r * a[i__1].r - d22.i * a[i__1].i, - z__3.i = d22.r * a[i__1].i + d22.i * a[i__1] + z__4.r = d22.r * a[i__1].r - d22.i * a[i__1].i, + z__4.i = d22.r * a[i__1].i + d22.i * a[i__1] .r; i__2 = j + (k - 1) * a_dim1; - z__2.r = z__3.r - a[i__2].r, z__2.i = z__3.i - a[i__2] + z__3.r = z__4.r - a[i__2].r, z__3.i = z__4.i - a[i__2] .i; - z__1.r = d12.r * z__2.r - d12.i * z__2.i, z__1.i = - d12.r * z__2.i + d12.i * z__2.r; + z_div(&z__2, &z__3, &d12); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; wk.r = z__1.r, wk.i = z__1.i; for (i__ = j; i__ >= 1; --i__) { i__1 = i__ + j * a_dim1; @@ -962,33 +952,33 @@ f"> */ d22.r = z__1.r, d22.i = z__1.i; z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * d22.i + d11.i * d22.r; - z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; + z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.; z_div(&z__1, &c_b1, &z__2); t.r = z__1.r, t.i = z__1.i; - z_div(&z__1, &t, &d21); - d21.r = z__1.r, d21.i = z__1.i; i__1 = *n; for (j = k + 2; j <= i__1; ++j) { i__2 = j + k * a_dim1; - z__3.r = d11.r * a[i__2].r - d11.i * a[i__2].i, - z__3.i = d11.r * a[i__2].i + d11.i * a[i__2] + z__4.r = d11.r * a[i__2].r - d11.i * a[i__2].i, + z__4.i = d11.r * a[i__2].i + d11.i * a[i__2] .r; i__3 = j + (k + 1) * a_dim1; - z__2.r = z__3.r - a[i__3].r, z__2.i = z__3.i - a[i__3] + z__3.r = z__4.r - a[i__3].r, z__3.i = z__4.i - a[i__3] .i; - z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = - d21.r * z__2.i + d21.i * z__2.r; + z_div(&z__2, &z__3, &d21); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; wk.r = z__1.r, wk.i = z__1.i; i__2 = j + (k + 1) * a_dim1; - z__3.r = d22.r * a[i__2].r - d22.i * a[i__2].i, - z__3.i = d22.r * a[i__2].i + d22.i * a[i__2] + z__4.r = d22.r * a[i__2].r - d22.i * a[i__2].i, + z__4.i = d22.r * a[i__2].i + d22.i * a[i__2] .r; i__3 = j + k * a_dim1; - z__2.r = z__3.r - a[i__3].r, z__2.i = z__3.i - a[i__3] + z__3.r = z__4.r - a[i__3].r, z__3.i = z__4.i - a[i__3] .i; - z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = - d21.r * z__2.i + d21.i * z__2.r; + z_div(&z__2, &z__3, &d21); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; wkp1.r = z__1.r, wkp1.i = z__1.i; i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { diff --git a/lapack-netlib/SRC/zsytf2.f b/lapack-netlib/SRC/zsytf2.f index 7542a0de16..26ed82a080 100644 --- a/lapack-netlib/SRC/zsytf2.f +++ b/lapack-netlib/SRC/zsytf2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZSYTF2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -127,7 +125,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16SYcomputational +*> \ingroup hetf2 * *> \par Further Details: * ===================== @@ -188,6 +186,7 @@ * * ===================================================================== SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -395,11 +394,10 @@ SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = CONE / ( D11*D22-CONE ) - D12 = T / D12 * DO 30 J = K - 2, 1, -1 - WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) ) - WK = D12*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K-1 )*WKM1 @@ -481,7 +479,8 @@ SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA ) ROWMAX = CABS1( A( IMAX, JMAX ) ) IF( IMAX.LT.N ) THEN - JMAX = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 ) + JMAX = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) ROWMAX = MAX( ROWMAX, CABS1( A( JMAX, IMAX ) ) ) END IF * @@ -513,7 +512,8 @@ SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * submatrix A(k:n,k:n) * IF( KP.LT.N ) - $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) CALL ZSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), $ LDA ) T = A( KK, KK ) @@ -568,11 +568,10 @@ SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = CONE / ( D11*D22-CONE ) - D21 = T / D21 * DO 60 J = K + 2, N - WK = D21*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) DO 50 I = J, N A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K+1 )*WKP1 diff --git a/lapack-netlib/SRC/zsytf2_rk.c b/lapack-netlib/SRC/zsytf2_rk.c index 673809fddd..e22adbe41d 100644 --- a/lapack-netlib/SRC/zsytf2_rk.c +++ b/lapack-netlib/SRC/zsytf2_rk.c @@ -246,11 +246,11 @@ typedef struct Namelist Namelist; #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; -#define mycycle_() continue; -#define myceiling_(w) {ceil(w)} -#define myhuge_(w) {HUGE_VAL} +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} -#define mymaxloc_(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} /* -- translated by f2c (version 20000121). You must link the resulting object file with the libraries: @@ -258,8 +258,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static doublecomplex c_b1 = {1.,0.}; @@ -273,7 +271,6 @@ static integer c__1 = 1; /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ZSYTF2_RK + dependencies */ /* > */ @@ -284,7 +281,6 @@ rk.f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -475,9 +471,7 @@ rk.f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complex16SYcomputational */ +/* > \ingroup hetf2_rk */ /* > \par Further Details: */ /* ===================== */ @@ -510,44 +504,39 @@ rk.f"> */ integer *lda, doublecomplex *e, integer *ipiv, integer *info) { /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; doublereal d__1, d__2; - doublecomplex z__1, z__2, z__3, z__4, z__5, z__6; + doublecomplex z__1, z__2, z__3, z__4; /* Local variables */ + integer i__, j, k, p; + doublecomplex t, d11, d12, d21, d22; + integer ii, kk, kp; + doublecomplex wk, wkm1, wkp1; logical done; integer imax, jmax; extern /* Subroutine */ void zsyr_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *); - integer i__, j, k, p; - doublecomplex t; doublereal alpha; extern logical lsame_(char *, char *); doublereal dtemp, sfmin; - integer itemp; extern /* Subroutine */ void zscal_(integer *, doublecomplex *, doublecomplex *, integer *); - integer kstep; + integer itemp, kstep; logical upper; extern /* Subroutine */ void zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); - doublecomplex d11, d12, d21, d22; - integer ii, kk; extern doublereal dlamch_(char *); - integer kp; doublereal absakk; - doublecomplex wk; extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); doublereal colmax; extern integer izamax_(integer *, doublecomplex *, integer *); doublereal rowmax; - doublecomplex wkm1, wkp1; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -557,7 +546,7 @@ rk.f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --e; --ipiv; @@ -913,29 +902,31 @@ rk.f"> */ d11.r = z__1.r, d11.i = z__1.i; z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * d22.i + d11.i * d22.r; - z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; + z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.; z_div(&z__1, &c_b1, &z__2); t.r = z__1.r, t.i = z__1.i; for (j = k - 2; j >= 1; --j) { i__1 = j + (k - 1) * a_dim1; - z__3.r = d11.r * a[i__1].r - d11.i * a[i__1].i, - z__3.i = d11.r * a[i__1].i + d11.i * a[i__1] + z__4.r = d11.r * a[i__1].r - d11.i * a[i__1].i, + z__4.i = d11.r * a[i__1].i + d11.i * a[i__1] .r; i__2 = j + k * a_dim1; - z__2.r = z__3.r - a[i__2].r, z__2.i = z__3.i - a[i__2] + z__3.r = z__4.r - a[i__2].r, z__3.i = z__4.i - a[i__2] .i; + z_div(&z__2, &z__3, &d12); z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i * z__2.r; wkm1.r = z__1.r, wkm1.i = z__1.i; i__1 = j + k * a_dim1; - z__3.r = d22.r * a[i__1].r - d22.i * a[i__1].i, - z__3.i = d22.r * a[i__1].i + d22.i * a[i__1] + z__4.r = d22.r * a[i__1].r - d22.i * a[i__1].i, + z__4.i = d22.r * a[i__1].i + d22.i * a[i__1] .r; i__2 = j + (k - 1) * a_dim1; - z__2.r = z__3.r - a[i__2].r, z__2.i = z__3.i - a[i__2] + z__3.r = z__4.r - a[i__2].r, z__3.i = z__4.i - a[i__2] .i; + z_div(&z__2, &z__3, &d12); z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i * z__2.r; wk.r = z__1.r, wk.i = z__1.i; @@ -943,17 +934,18 @@ rk.f"> */ for (i__ = j; i__ >= 1; --i__) { i__1 = i__ + j * a_dim1; i__2 = i__ + j * a_dim1; - z_div(&z__4, &a[i__ + k * a_dim1], &d12); - z__3.r = z__4.r * wk.r - z__4.i * wk.i, z__3.i = - z__4.r * wk.i + z__4.i * wk.r; + i__3 = i__ + k * a_dim1; + z__3.r = a[i__3].r * wk.r - a[i__3].i * wk.i, + z__3.i = a[i__3].r * wk.i + a[i__3].i * + wk.r; z__2.r = a[i__2].r - z__3.r, z__2.i = a[i__2].i - z__3.i; - z_div(&z__6, &a[i__ + (k - 1) * a_dim1], &d12); - z__5.r = z__6.r * wkm1.r - z__6.i * wkm1.i, - z__5.i = z__6.r * wkm1.i + z__6.i * + i__4 = i__ + (k - 1) * a_dim1; + z__4.r = a[i__4].r * wkm1.r - a[i__4].i * wkm1.i, + z__4.i = a[i__4].r * wkm1.i + a[i__4].i * wkm1.r; - z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - - z__5.i; + z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - + z__4.i; a[i__1].r = z__1.r, a[i__1].i = z__1.i; /* L20: */ } @@ -961,11 +953,9 @@ rk.f"> */ /* Store U(k) and U(k-1) in cols k and k-1 for row J */ i__1 = j + k * a_dim1; - z_div(&z__1, &wk, &d12); - a[i__1].r = z__1.r, a[i__1].i = z__1.i; + a[i__1].r = wk.r, a[i__1].i = wk.i; i__1 = j + (k - 1) * a_dim1; - z_div(&z__1, &wkm1, &d12); - a[i__1].r = z__1.r, a[i__1].i = z__1.i; + a[i__1].r = wkm1.r, a[i__1].i = wkm1.i; /* L30: */ } @@ -1332,32 +1322,34 @@ rk.f"> */ d22.r = z__1.r, d22.i = z__1.i; z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * d22.i + d11.i * d22.r; - z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; + z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.; z_div(&z__1, &c_b1, &z__2); t.r = z__1.r, t.i = z__1.i; i__1 = *n; for (j = k + 2; j <= i__1; ++j) { -/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ +/* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J */ i__2 = j + k * a_dim1; - z__3.r = d11.r * a[i__2].r - d11.i * a[i__2].i, - z__3.i = d11.r * a[i__2].i + d11.i * a[i__2] + z__4.r = d11.r * a[i__2].r - d11.i * a[i__2].i, + z__4.i = d11.r * a[i__2].i + d11.i * a[i__2] .r; i__3 = j + (k + 1) * a_dim1; - z__2.r = z__3.r - a[i__3].r, z__2.i = z__3.i - a[i__3] + z__3.r = z__4.r - a[i__3].r, z__3.i = z__4.i - a[i__3] .i; + z_div(&z__2, &z__3, &d21); z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i * z__2.r; wk.r = z__1.r, wk.i = z__1.i; i__2 = j + (k + 1) * a_dim1; - z__3.r = d22.r * a[i__2].r - d22.i * a[i__2].i, - z__3.i = d22.r * a[i__2].i + d22.i * a[i__2] + z__4.r = d22.r * a[i__2].r - d22.i * a[i__2].i, + z__4.i = d22.r * a[i__2].i + d22.i * a[i__2] .r; i__3 = j + k * a_dim1; - z__2.r = z__3.r - a[i__3].r, z__2.i = z__3.i - a[i__3] + z__3.r = z__4.r - a[i__3].r, z__3.i = z__4.i - a[i__3] .i; + z_div(&z__2, &z__3, &d21); z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i * z__2.r; wkp1.r = z__1.r, wkp1.i = z__1.i; @@ -1368,17 +1360,18 @@ rk.f"> */ for (i__ = j; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; i__4 = i__ + j * a_dim1; - z_div(&z__4, &a[i__ + k * a_dim1], &d21); - z__3.r = z__4.r * wk.r - z__4.i * wk.i, z__3.i = - z__4.r * wk.i + z__4.i * wk.r; + i__5 = i__ + k * a_dim1; + z__3.r = a[i__5].r * wk.r - a[i__5].i * wk.i, + z__3.i = a[i__5].r * wk.i + a[i__5].i * + wk.r; z__2.r = a[i__4].r - z__3.r, z__2.i = a[i__4].i - z__3.i; - z_div(&z__6, &a[i__ + (k + 1) * a_dim1], &d21); - z__5.r = z__6.r * wkp1.r - z__6.i * wkp1.i, - z__5.i = z__6.r * wkp1.i + z__6.i * + i__6 = i__ + (k + 1) * a_dim1; + z__4.r = a[i__6].r * wkp1.r - a[i__6].i * wkp1.i, + z__4.i = a[i__6].r * wkp1.i + a[i__6].i * wkp1.r; - z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - - z__5.i; + z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - + z__4.i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L50: */ } @@ -1386,11 +1379,9 @@ rk.f"> */ /* Store L(k) and L(k+1) in cols k and k+1 for row J */ i__2 = j + k * a_dim1; - z_div(&z__1, &wk, &d21); - a[i__2].r = z__1.r, a[i__2].i = z__1.i; + a[i__2].r = wk.r, a[i__2].i = wk.i; i__2 = j + (k + 1) * a_dim1; - z_div(&z__1, &wkp1, &d21); - a[i__2].r = z__1.r, a[i__2].i = z__1.i; + a[i__2].r = wkp1.r, a[i__2].i = wkp1.i; /* L60: */ } diff --git a/lapack-netlib/SRC/zsytf2_rk.f b/lapack-netlib/SRC/zsytf2_rk.f index d0dd3a278d..66bac797a4 100644 --- a/lapack-netlib/SRC/zsytf2_rk.f +++ b/lapack-netlib/SRC/zsytf2_rk.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZSYTF2_RK + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -208,7 +206,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16SYcomputational +*> \ingroup hetf2_rk * *> \par Further Details: * ===================== @@ -238,6 +236,7 @@ * * ===================================================================== SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -469,7 +468,8 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * the interchanges in columns k+1:N. * IF( K.LT.N ) - $ CALL ZSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA ) + $ CALL ZSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), + $ LDA ) * END IF * @@ -484,7 +484,8 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) IF( KP.GT.1 ) $ CALL ZSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) - $ CALL ZSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ CALL ZSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, + $ KP+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) @@ -526,7 +527,8 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * = A - W(k)*1/D(k)*W(k)**T * D11 = CONE / A( K, K ) - CALL ZSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL ZSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) * * Store U(k) in column k * @@ -545,7 +547,8 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * = A - W(k)*(1/D(k))*W(k)**T * = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T * - CALL ZSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL ZSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) END IF * * Store the superdiagonal element of D in array E @@ -579,18 +582,18 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) - WK = T*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - - $ ( A( I, K-1 ) / D12 )*WKM1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K-1 )*WKM1 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D12 - A( J, K-1 ) = WKM1 / D12 + A( J, K ) = WK + A( J, K-1 ) = WKM1 * 30 CONTINUE * @@ -703,14 +706,16 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * Determine both ROWMAX and JMAX. * IF( IMAX.NE.K ) THEN - JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA ) + JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), + $ LDA ) ROWMAX = CABS1( A( IMAX, JMAX ) ) ELSE ROWMAX = ZERO END IF * IF( IMAX.LT.N ) THEN - ITEMP = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ), + ITEMP = IMAX + IZAMAX( N-IMAX, A( IMAX+1, + $ IMAX ), $ 1 ) DTEMP = CABS1( A( ITEMP, IMAX ) ) IF( DTEMP.GT.ROWMAX ) THEN @@ -769,7 +774,8 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) IF( P.LT.N ) $ CALL ZSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) IF( P.GT.(K+1) ) - $ CALL ZSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + $ CALL ZSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), + $ LDA ) T = A( K, K ) A( K, K ) = A( P, P ) A( P, P ) = T @@ -791,9 +797,11 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * submatrix A(k:n,k:n) * IF( KP.LT.N ) - $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) - $ CALL ZSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ CALL ZSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, + $ KK+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) @@ -890,22 +898,22 @@ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N - A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - - $ ( A( I, K+1 ) / D21 )*WKP1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K+1 )*WKP1 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D21 - A( J, K+1 ) = WKP1 / D21 + A( J, K ) = WK + A( J, K+1 ) = WKP1 * 60 CONTINUE * diff --git a/lapack-netlib/SRC/zsytf2_rook.c b/lapack-netlib/SRC/zsytf2_rook.c index a87108573b..df30075907 100644 --- a/lapack-netlib/SRC/zsytf2_rook.c +++ b/lapack-netlib/SRC/zsytf2_rook.c @@ -246,11 +246,11 @@ typedef struct Namelist Namelist; #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; -#define mycycle_() continue; -#define myceiling_(w) {ceil(w)} -#define myhuge_(w) {HUGE_VAL} +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} -#define mymaxloc_(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} /* -- translated by f2c (version 20000121). You must link the resulting object file with the libraries: @@ -258,8 +258,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static doublecomplex c_b1 = {1.,0.}; @@ -273,7 +271,6 @@ ed Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm). */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ZSYTF2_ROOK + dependencies */ /* > */ @@ -284,7 +281,6 @@ rook.f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -396,9 +392,7 @@ rook.f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date November 2013 */ - -/* > \ingroup complex16SYcomputational */ +/* > \ingroup hetf2_rook */ /* > \par Further Details: */ /* ===================== */ @@ -463,17 +457,19 @@ rook.f"> */ integer *lda, integer *ipiv, integer *info) { /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; doublereal d__1, d__2; - doublecomplex z__1, z__2, z__3, z__4, z__5, z__6; + doublecomplex z__1, z__2, z__3, z__4; /* Local variables */ + integer i__, j, k, p; + doublecomplex t, d11, d12, d21, d22; + integer ii, kk, kp; + doublecomplex wk, wkm1, wkp1; logical done; integer imax, jmax; extern /* Subroutine */ void zsyr_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *); - integer i__, j, k, p; - doublecomplex t; doublereal alpha; extern logical lsame_(char *, char *); doublereal dtemp, sfmin; @@ -483,23 +479,17 @@ rook.f"> */ logical upper; extern /* Subroutine */ void zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); - doublecomplex d11, d12, d21, d22; - integer ii, kk; extern doublereal dlamch_(char *); - integer kp; doublereal absakk; - doublecomplex wk; extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); doublereal colmax; extern integer izamax_(integer *, doublecomplex *, integer *); doublereal rowmax; - doublecomplex wkm1, wkp1; -/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* November 2013 */ /* ===================================================================== */ @@ -509,7 +499,7 @@ rook.f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --ipiv; @@ -825,29 +815,31 @@ rook.f"> */ d11.r = z__1.r, d11.i = z__1.i; z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * d22.i + d11.i * d22.r; - z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; + z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.; z_div(&z__1, &c_b1, &z__2); t.r = z__1.r, t.i = z__1.i; for (j = k - 2; j >= 1; --j) { i__1 = j + (k - 1) * a_dim1; - z__3.r = d11.r * a[i__1].r - d11.i * a[i__1].i, - z__3.i = d11.r * a[i__1].i + d11.i * a[i__1] + z__4.r = d11.r * a[i__1].r - d11.i * a[i__1].i, + z__4.i = d11.r * a[i__1].i + d11.i * a[i__1] .r; i__2 = j + k * a_dim1; - z__2.r = z__3.r - a[i__2].r, z__2.i = z__3.i - a[i__2] + z__3.r = z__4.r - a[i__2].r, z__3.i = z__4.i - a[i__2] .i; + z_div(&z__2, &z__3, &d12); z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i * z__2.r; wkm1.r = z__1.r, wkm1.i = z__1.i; i__1 = j + k * a_dim1; - z__3.r = d22.r * a[i__1].r - d22.i * a[i__1].i, - z__3.i = d22.r * a[i__1].i + d22.i * a[i__1] + z__4.r = d22.r * a[i__1].r - d22.i * a[i__1].i, + z__4.i = d22.r * a[i__1].i + d22.i * a[i__1] .r; i__2 = j + (k - 1) * a_dim1; - z__2.r = z__3.r - a[i__2].r, z__2.i = z__3.i - a[i__2] + z__3.r = z__4.r - a[i__2].r, z__3.i = z__4.i - a[i__2] .i; + z_div(&z__2, &z__3, &d12); z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i * z__2.r; wk.r = z__1.r, wk.i = z__1.i; @@ -855,17 +847,18 @@ rook.f"> */ for (i__ = j; i__ >= 1; --i__) { i__1 = i__ + j * a_dim1; i__2 = i__ + j * a_dim1; - z_div(&z__4, &a[i__ + k * a_dim1], &d12); - z__3.r = z__4.r * wk.r - z__4.i * wk.i, z__3.i = - z__4.r * wk.i + z__4.i * wk.r; + i__3 = i__ + k * a_dim1; + z__3.r = a[i__3].r * wk.r - a[i__3].i * wk.i, + z__3.i = a[i__3].r * wk.i + a[i__3].i * + wk.r; z__2.r = a[i__2].r - z__3.r, z__2.i = a[i__2].i - z__3.i; - z_div(&z__6, &a[i__ + (k - 1) * a_dim1], &d12); - z__5.r = z__6.r * wkm1.r - z__6.i * wkm1.i, - z__5.i = z__6.r * wkm1.i + z__6.i * + i__4 = i__ + (k - 1) * a_dim1; + z__4.r = a[i__4].r * wkm1.r - a[i__4].i * wkm1.i, + z__4.i = a[i__4].r * wkm1.i + a[i__4].i * wkm1.r; - z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - - z__5.i; + z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - + z__4.i; a[i__1].r = z__1.r, a[i__1].i = z__1.i; /* L20: */ } @@ -873,11 +866,9 @@ rook.f"> */ /* Store U(k) and U(k-1) in cols k and k-1 for row J */ i__1 = j + k * a_dim1; - z_div(&z__1, &wk, &d12); - a[i__1].r = z__1.r, a[i__1].i = z__1.i; + a[i__1].r = wk.r, a[i__1].i = wk.i; i__1 = j + (k - 1) * a_dim1; - z_div(&z__1, &wkm1, &d12); - a[i__1].r = z__1.r, a[i__1].i = z__1.i; + a[i__1].r = wkm1.r, a[i__1].i = wkm1.i; /* L30: */ } @@ -1189,32 +1180,34 @@ rook.f"> */ d22.r = z__1.r, d22.i = z__1.i; z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * d22.i + d11.i * d22.r; - z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; + z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.; z_div(&z__1, &c_b1, &z__2); t.r = z__1.r, t.i = z__1.i; i__1 = *n; for (j = k + 2; j <= i__1; ++j) { -/* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J */ +/* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J */ i__2 = j + k * a_dim1; - z__3.r = d11.r * a[i__2].r - d11.i * a[i__2].i, - z__3.i = d11.r * a[i__2].i + d11.i * a[i__2] + z__4.r = d11.r * a[i__2].r - d11.i * a[i__2].i, + z__4.i = d11.r * a[i__2].i + d11.i * a[i__2] .r; i__3 = j + (k + 1) * a_dim1; - z__2.r = z__3.r - a[i__3].r, z__2.i = z__3.i - a[i__3] + z__3.r = z__4.r - a[i__3].r, z__3.i = z__4.i - a[i__3] .i; + z_div(&z__2, &z__3, &d21); z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i * z__2.r; wk.r = z__1.r, wk.i = z__1.i; i__2 = j + (k + 1) * a_dim1; - z__3.r = d22.r * a[i__2].r - d22.i * a[i__2].i, - z__3.i = d22.r * a[i__2].i + d22.i * a[i__2] + z__4.r = d22.r * a[i__2].r - d22.i * a[i__2].i, + z__4.i = d22.r * a[i__2].i + d22.i * a[i__2] .r; i__3 = j + k * a_dim1; - z__2.r = z__3.r - a[i__3].r, z__2.i = z__3.i - a[i__3] + z__3.r = z__4.r - a[i__3].r, z__3.i = z__4.i - a[i__3] .i; + z_div(&z__2, &z__3, &d21); z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i * z__2.r; wkp1.r = z__1.r, wkp1.i = z__1.i; @@ -1225,17 +1218,18 @@ rook.f"> */ for (i__ = j; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; i__4 = i__ + j * a_dim1; - z_div(&z__4, &a[i__ + k * a_dim1], &d21); - z__3.r = z__4.r * wk.r - z__4.i * wk.i, z__3.i = - z__4.r * wk.i + z__4.i * wk.r; + i__5 = i__ + k * a_dim1; + z__3.r = a[i__5].r * wk.r - a[i__5].i * wk.i, + z__3.i = a[i__5].r * wk.i + a[i__5].i * + wk.r; z__2.r = a[i__4].r - z__3.r, z__2.i = a[i__4].i - z__3.i; - z_div(&z__6, &a[i__ + (k + 1) * a_dim1], &d21); - z__5.r = z__6.r * wkp1.r - z__6.i * wkp1.i, - z__5.i = z__6.r * wkp1.i + z__6.i * + i__6 = i__ + (k + 1) * a_dim1; + z__4.r = a[i__6].r * wkp1.r - a[i__6].i * wkp1.i, + z__4.i = a[i__6].r * wkp1.i + a[i__6].i * wkp1.r; - z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - - z__5.i; + z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - + z__4.i; a[i__3].r = z__1.r, a[i__3].i = z__1.i; /* L50: */ } @@ -1243,11 +1237,9 @@ rook.f"> */ /* Store L(k) and L(k+1) in cols k and k+1 for row J */ i__2 = j + k * a_dim1; - z_div(&z__1, &wk, &d21); - a[i__2].r = z__1.r, a[i__2].i = z__1.i; + a[i__2].r = wk.r, a[i__2].i = wk.i; i__2 = j + (k + 1) * a_dim1; - z_div(&z__1, &wkp1, &d21); - a[i__2].r = z__1.r, a[i__2].i = z__1.i; + a[i__2].r = wkp1.r, a[i__2].i = wkp1.i; /* L60: */ } diff --git a/lapack-netlib/SRC/zsytf2_rook.f b/lapack-netlib/SRC/zsytf2_rook.f index cbfb57e266..5ca1761969 100644 --- a/lapack-netlib/SRC/zsytf2_rook.f +++ b/lapack-netlib/SRC/zsytf2_rook.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZSYTF2_ROOK + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -129,7 +127,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16SYcomputational +*> \ingroup hetf2_rook * *> \par Further Details: * ===================== @@ -191,6 +189,7 @@ * * ===================================================================== SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -418,7 +417,8 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) IF( KP.GT.1 ) $ CALL ZSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) - $ CALL ZSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ CALL ZSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, + $ KP+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) @@ -452,7 +452,8 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * = A - W(k)*1/D(k)*W(k)**T * D11 = CONE / A( K, K ) - CALL ZSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL ZSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) * * Store U(k) in column k * @@ -471,7 +472,8 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * = A - W(k)*(1/D(k))*W(k)**T * = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T * - CALL ZSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + CALL ZSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, + $ LDA ) END IF END IF * @@ -500,18 +502,18 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 30 J = K - 2, 1, -1 * - WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) - WK = T*( D22*A( J, K )-A( J, K-1 ) ) + WKM1 = T*( ( D11*A( J, K-1 )-A( J, K ) ) / D12 ) + WK = T*( ( D22*A( J, K )-A( J, K-1 ) ) / D12 ) * DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - - $ ( A( I, K-1 ) / D12 )*WKM1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K-1 )*WKM1 20 CONTINUE * * Store U(k) and U(k-1) in cols k and k-1 for row J * - A( J, K ) = WK / D12 - A( J, K-1 ) = WKM1 / D12 + A( J, K ) = WK + A( J, K-1 ) = WKM1 * 30 CONTINUE * @@ -601,14 +603,16 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * Determine both ROWMAX and JMAX. * IF( IMAX.NE.K ) THEN - JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA ) + JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), + $ LDA ) ROWMAX = CABS1( A( IMAX, JMAX ) ) ELSE ROWMAX = ZERO END IF * IF( IMAX.LT.N ) THEN - ITEMP = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ), + ITEMP = IMAX + IZAMAX( N-IMAX, A( IMAX+1, + $ IMAX ), $ 1 ) DTEMP = CABS1( A( ITEMP, IMAX ) ) IF( DTEMP.GT.ROWMAX ) THEN @@ -667,7 +671,8 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) IF( P.LT.N ) $ CALL ZSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) IF( P.GT.(K+1) ) - $ CALL ZSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + $ CALL ZSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), + $ LDA ) T = A( K, K ) A( K, K ) = A( P, P ) A( P, P ) = T @@ -682,9 +687,11 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * submatrix A(k:n,k:n) * IF( KP.LT.N ) - $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), + $ 1 ) IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) - $ CALL ZSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ CALL ZSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, + $ KK+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) @@ -769,22 +776,22 @@ SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) * DO 60 J = K + 2, N * -* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* Compute ( W(k)W(k+1) ) * inv(D(k)) for row J * - WK = T*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) + WK = T*( ( D11*A( J, K )-A( J, K+1 ) ) / D21 ) + WKP1 = T*( ( D22*A( J, K+1 )-A( J, K ) ) / D21 ) * * Perform a rank-2 update of A(k+2:n,k+2:n) * DO 50 I = J, N - A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - - $ ( A( I, K+1 ) / D21 )*WKP1 + A( I, J ) = A( I, J ) - A( I, K )*WK - + $ A( I, K+1 )*WKP1 50 CONTINUE * * Store L(k) and L(k+1) in cols k and k+1 for row J * - A( J, K ) = WK / D21 - A( J, K+1 ) = WKP1 / D21 + A( J, K ) = WK + A( J, K+1 ) = WKP1 * 60 CONTINUE * diff --git a/lapack-netlib/TESTING/LIN/alahd.f b/lapack-netlib/TESTING/LIN/alahd.f index b04a3f7961..880effbebd 100644 --- a/lapack-netlib/TESTING/LIN/alahd.f +++ b/lapack-netlib/TESTING/LIN/alahd.f @@ -300,7 +300,7 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) END IF WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) IF( SORD ) THEN - WRITE( IOUNIT, FMT = 9972 ) + WRITE( IOUNIT, FMT = 7972 ) ELSE WRITE( IOUNIT, FMT = 9971 ) END IF @@ -913,6 +913,21 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) $ 'TRF, no test ratios are computed)' ) * * SSY, SSR, SSP, CHE, CHR, CHP matrix types +* +* +* SSY matrix types +* + 7972 FORMAT( 4X, '1. Diagonal', 24X, + $ '6. Last n/2 rows and columns zero', / 4X, + $ '2. Random, CNDNUM = 2', 14X, + $ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, + $ '3. First row and column zero', 7X, + $ '8. Random, CNDNUM = 0.1/EPS', / 4X, + $ '4. Last row and column zero', 8X, + $ '9. Scaled near underflow', / 4X, + $ '5. Middle row and column zero', 5X, + $ '10. Scaled near overflow', / 39X, + $ '11. Subnormal 2 by 2 pivot block' ) * 9972 FORMAT( 4X, '1. Diagonal', 24X, $ '6. Last n/2 rows and columns zero', / 4X, diff --git a/lapack-netlib/TESTING/LIN/dchkaa.F b/lapack-netlib/TESTING/LIN/dchkaa.F index 856185c65a..ed5c7ab908 100644 --- a/lapack-netlib/TESTING/LIN/dchkaa.F +++ b/lapack-netlib/TESTING/LIN/dchkaa.F @@ -197,19 +197,40 @@ PROGRAM DCHKAA * .. Allocate memory dynamically .. * ALLOCATE ( IWORK( 34*NMAX ), STAT = AllocateStatus ) - IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + IF (AllocateStatus /= 0) THEN + WRITE( NOUT, FMT = * )'*** Not enough memory ***' + STOP 1 + END IF ALLOCATE ( A( ( KDMAX+1 )*NMAX, 8 ), STAT = AllocateStatus ) - IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + IF (AllocateStatus /= 0) THEN + WRITE( NOUT, FMT = * )'*** Not enough memory ***' + STOP 1 + END IF ALLOCATE ( B( NMAX*MAXRHS, 4 ), STAT = AllocateStatus ) - IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + IF (AllocateStatus /= 0) THEN + WRITE( NOUT, FMT = * )'*** Not enough memory ***' + STOP 1 + END IF ALLOCATE ( WORK( NMAX, 3*NMAX+MAXRHS+30 ), STAT = AllocateStatus ) - IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + IF (AllocateStatus /= 0) THEN + WRITE( NOUT, FMT = * )'*** Not enough memory ***' + STOP 1 + END IF ALLOCATE ( E( NMAX ), STAT = AllocateStatus ) - IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + IF (AllocateStatus /= 0) THEN + WRITE( NOUT, FMT = * )'*** Not enough memory ***' + STOP 1 + END IF ALLOCATE ( S( 2*NMAX ), STAT = AllocateStatus ) - IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + IF (AllocateStatus /= 0) THEN + WRITE( NOUT, FMT = * )'*** Not enough memory ***' + STOP 1 + END IF ALLOCATE ( RWORK( 5*NMAX+2*MAXRHS ), STAT = AllocateStatus ) - IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + IF (AllocateStatus /= 0) THEN + WRITE( NOUT, FMT = * )'*** Not enough memory ***' + STOP 1 + END IF * * .. Executable Statements .. * @@ -393,7 +414,7 @@ PROGRAM DCHKAA * IF( FATAL ) THEN WRITE( NOUT, FMT = 9999 ) - STOP + STOP 1 END IF * * Calculate and print the machine dependent constants. @@ -650,7 +671,7 @@ PROGRAM DCHKAA * SY: symmetric indefinite matrices, * with partial (Bunch-Kaufman) pivoting algorithm * - NTYPES = 10 + NTYPES = 11 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN @@ -1110,7 +1131,8 @@ PROGRAM DCHKAA DEALLOCATE (E, STAT = AllocateStatus) DEALLOCATE (S, STAT = AllocateStatus) DEALLOCATE (WORK, STAT = AllocateStatus) - DEALLOCATE (RWORK, STAT = AllocateStatus) + DEALLOCATE (RWORK, STAT = AllocateStatus) + DEALLOCATE (IWORK, STAT = AllocateStatus) * 9999 FORMAT( / ' Execution not attempted due to input errors' ) 9998 FORMAT( / ' End of tests' ) diff --git a/lapack-netlib/TESTING/LIN/dchksy.f b/lapack-netlib/TESTING/LIN/dchksy.f index 8d127cd3b6..0292c8651d 100644 --- a/lapack-netlib/TESTING/LIN/dchksy.f +++ b/lapack-netlib/TESTING/LIN/dchksy.f @@ -167,6 +167,7 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) + IMPLICIT NONE * * -- LAPACK test routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -176,6 +177,7 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, LOGICAL TSTERR INTEGER NMAX, NN, NNB, NNS, NOUT DOUBLE PRECISION THRESH + DOUBLE PRECISION SUBNRM * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) @@ -189,8 +191,10 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) + DOUBLE PRECISION FOUR + PARAMETER ( FOUR = 4.0D+0 ) INTEGER NTYPES - PARAMETER ( NTYPES = 10 ) + PARAMETER ( NTYPES = 11 ) INTEGER NTESTS PARAMETER ( NTESTS = 9 ) * .. @@ -209,13 +213,16 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, DOUBLE PRECISION RESULT( NTESTS ) * .. * .. External Functions .. + LOGICAL DISNAN + DOUBLE PRECISION DLAMCH DOUBLE PRECISION DGET06, DLANSY EXTERNAL DGET06, DLANSY + EXTERNAL DISNAN, DLAMCH * .. * .. External Subroutines .. EXTERNAL ALAERH, ALAHD, ALASUM, DERRSY, DGET04, DLACPY, $ DLARHS, DLATB4, DLATMS, DPOT02, DPOT03, DPOT05, - $ DSYCON, DSYRFS, DSYT01, DSYTRF, + $ DSCAL, DSYCON, DSYRFS, DSYT01, DSYTRF, $ DSYTRI2, DSYTRS, DSYTRS2, XLAENV * .. * .. Intrinsic Functions .. @@ -386,6 +393,32 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, IZERO = 0 END IF * +* Type 11: scale two adjacent rows and columns into the +* subnormal range and give them a 2 by 2 pivot block whose +* off-diagonal entry is four times its diagonal, at the +* end the factorization starts from. Inverting that pivot +* through the reciprocal of the off-diagonal entry +* overflows. +* + IF( IMAT.EQ.11 .AND. N.GE.2 ) THEN + SUBNRM = DLAMCH( 'Safe minimum' ) / 512 + IF( IUPLO.EQ.1 ) THEN + I1 = N - 1 + ELSE + I1 = 1 + END IF + I2 = I1 + 1 + CALL DSCAL( N, SUBNRM, A( I1 ), LDA ) + CALL DSCAL( N, SUBNRM, A( I2 ), LDA ) + CALL DSCAL( N, SUBNRM, A( ( I1-1 )*LDA+1 ), 1 ) + CALL DSCAL( N, SUBNRM, A( ( I2-1 )*LDA+1 ), 1 ) + A( ( I1-1 )*LDA+I1 ) = SUBNRM + A( ( I2-1 )*LDA+I2 ) = SUBNRM + A( ( I2-1 )*LDA+I1 ) = FOUR*SUBNRM + A( ( I1-1 )*LDA+I2 ) = FOUR*SUBNRM + IZERO = 0 + END IF +* * End generate the test matrix A. * * Do for each value of NB in NBVAL @@ -439,7 +472,7 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * * Set the condition estimate flag if the INFO is not 0. * - IF( INFO.NE.0 ) THEN + IF( INFO.NE.0 .OR. IMAT.EQ.11 ) THEN TRFCON = .TRUE. ELSE TRFCON = .FALSE. @@ -484,7 +517,8 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * the threshold. * DO 110 K = 1, NT - IF( RESULT( K ).GE.THRESH ) THEN + IF( RESULT( K ).GE.THRESH .OR. + $ DISNAN( RESULT( K ) ) ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, @@ -623,6 +657,8 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * Get an estimate of RCOND = 1/CNDNUM. * 140 CONTINUE + IF( IMAT.EQ.11 ) + $ GO TO 150 ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK ) SRNAMT = 'DSYCON' CALL DSYCON( UPLO, N, AFAC, LDA, IWORK, ANORM, RCOND, @@ -655,10 +691,69 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 170 CONTINUE 180 CONTINUE * +* +* Check an exact zero pivot created by updating a rank-one block +* when the singular matrix tests are requested. +* Unlike a row that is zero on input, its original diagonal must +* be replaced by the updated zero before returning the factors. +* + IF( .NOT.DOTYPE( 3 ) ) GO TO 260 + DO 250 IN = 1, NN + N = NVAL( IN ) + IF( N.LT.3 ) GO TO 250 + LDA = N + DO 240 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) + I1 = 1 + IF( IUPLO.EQ.1 ) I1 = N - 1 + I2 = I1 + 1 + IZERO = I2 + IF( IUPLO.EQ.1 ) IZERO = I1 + DO 230 MODE = 1, 1 + DO 200 J = 1, N + DO 190 I = 1, N + A( I+( J-1 )*LDA ) = ZERO + 190 CONTINUE + A( J+( J-1 )*LDA ) = 1.0D+0 + 200 CONTINUE + A( I1+( I1-1 )*LDA ) = 0.0625D+0 + A( I2+( I2-1 )*LDA ) = 0.0625D+0 + A( I1+( I2-1 )*LDA ) = 0.0625D+0 + A( I2+( I1-1 )*LDA ) = 0.0625D+0 + DO 220 INB = 1, NNB + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'DSYTRF' + CALL DSYTRF( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) + IF( INFO.NE.IZERO ) + $ CALL ALAERH( PATH, 'DSYTRF', INFO, IZERO, + $ UPLO, N, N, -1, -1, NB, 3, NFAIL, + $ NERRS, NOUT ) + CALL DSYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + IF( RESULT( 1 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9996 )UPLO, N, NB, MODE, + $ RESULT( 1 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE +* * Print a summary of the results. * CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) * + 9996 FORMAT( ' Zero pivot: UPLO = ''', A1, ''', N =', I5, + $ ', NB =', I4, ', mode =', I2, ', ratio =', G12.5 ) 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', $ I2, ', test ', I2, ', ratio =', G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', diff --git a/lapack-netlib/TESTING/LIN/schkaa.F b/lapack-netlib/TESTING/LIN/schkaa.F index 25c455d4fa..bb5b0af2cc 100644 --- a/lapack-netlib/TESTING/LIN/schkaa.F +++ b/lapack-netlib/TESTING/LIN/schkaa.F @@ -194,19 +194,40 @@ PROGRAM SCHKAA * .. Allocate memory dynamically .. * ALLOCATE ( IWORK( 34*NMAX ), STAT = AllocateStatus ) - IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + IF (AllocateStatus /= 0) THEN + WRITE( NOUT, FMT = * )'*** Not enough memory ***' + STOP 1 + END IF ALLOCATE ( A( ( KDMAX+1 )*NMAX, 8 ), STAT = AllocateStatus ) - IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + IF (AllocateStatus /= 0) THEN + WRITE( NOUT, FMT = * )'*** Not enough memory ***' + STOP 1 + END IF ALLOCATE ( B( NMAX*MAXRHS, 4 ), STAT = AllocateStatus ) - IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + IF (AllocateStatus /= 0) THEN + WRITE( NOUT, FMT = * )'*** Not enough memory ***' + STOP 1 + END IF ALLOCATE ( WORK( NMAX, 3*NMAX+MAXRHS+30 ), STAT = AllocateStatus ) - IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + IF (AllocateStatus /= 0) THEN + WRITE( NOUT, FMT = * )'*** Not enough memory ***' + STOP 1 + END IF ALLOCATE ( E( NMAX ), STAT = AllocateStatus ) - IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + IF (AllocateStatus /= 0) THEN + WRITE( NOUT, FMT = * )'*** Not enough memory ***' + STOP 1 + END IF ALLOCATE ( S( 2*NMAX ), STAT = AllocateStatus ) - IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + IF (AllocateStatus /= 0) THEN + WRITE( NOUT, FMT = * )'*** Not enough memory ***' + STOP 1 + END IF ALLOCATE ( RWORK( 5*NMAX+2*MAXRHS ), STAT = AllocateStatus ) - IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + IF (AllocateStatus /= 0) THEN + WRITE( NOUT, FMT = * )'*** Not enough memory ***' + STOP 1 + END IF * .. * .. Executable Statements .. * @@ -390,7 +411,7 @@ PROGRAM SCHKAA * IF( FATAL ) THEN WRITE( NOUT, FMT = 9999 ) - STOP + STOP 1 END IF * * Calculate and print the machine dependent constants. @@ -646,7 +667,7 @@ PROGRAM SCHKAA * SY: symmetric indefinite matrices, * with partial (Bunch-Kaufman) pivoting algorithm * - NTYPES = 10 + NTYPES = 11 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN @@ -1103,7 +1124,8 @@ PROGRAM SCHKAA DEALLOCATE (E, STAT = AllocateStatus) DEALLOCATE (S, STAT = AllocateStatus) DEALLOCATE (WORK, STAT = AllocateStatus) - DEALLOCATE (RWORK, STAT = AllocateStatus) + DEALLOCATE (RWORK, STAT = AllocateStatus) + DEALLOCATE (IWORK, STAT = AllocateStatus) * 9999 FORMAT( / ' Execution not attempted due to input errors' ) 9998 FORMAT( / ' End of tests' ) diff --git a/lapack-netlib/TESTING/LIN/schksy.f b/lapack-netlib/TESTING/LIN/schksy.f index dc94b34924..032bdc5dff 100644 --- a/lapack-netlib/TESTING/LIN/schksy.f +++ b/lapack-netlib/TESTING/LIN/schksy.f @@ -167,6 +167,7 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) + IMPLICIT NONE * * -- LAPACK test routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -176,6 +177,7 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, LOGICAL TSTERR INTEGER NMAX, NN, NNB, NNS, NOUT REAL THRESH + REAL SUBNRM * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) @@ -189,8 +191,10 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) + REAL FOUR + PARAMETER ( FOUR = 4.0E+0 ) INTEGER NTYPES - PARAMETER ( NTYPES = 10 ) + PARAMETER ( NTYPES = 11 ) INTEGER NTESTS PARAMETER ( NTESTS = 9 ) * .. @@ -209,13 +213,16 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, REAL RESULT( NTESTS ) * .. * .. External Functions .. + LOGICAL SISNAN + REAL SLAMCH REAL SGET06, SLANSY EXTERNAL SGET06, SLANSY + EXTERNAL SISNAN, SLAMCH * .. * .. External Subroutines .. EXTERNAL ALAERH, ALAHD, ALASUM, SERRSY, SGET04, SLACPY, $ SLARHS, SLATB4, SLATMS, SPOT02, SPOT03, SPOT05, - $ SSYCON, SSYCONV, SSYRFS, SSYT01, SSYTRF, + $ SSCAL, SSYCON, SSYRFS, SSYT01, SSYTRF, $ SSYTRI2, SSYTRS, SSYTRS2, XLAENV * .. * .. Intrinsic Functions .. @@ -385,6 +392,32 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, IZERO = 0 END IF * +* Type 11: scale two adjacent rows and columns into the +* subnormal range and give them a 2 by 2 pivot block whose +* off-diagonal entry is four times its diagonal, at the +* end the factorization starts from. Inverting that pivot +* through the reciprocal of the off-diagonal entry +* overflows. +* + IF( IMAT.EQ.11 .AND. N.GE.2 ) THEN + SUBNRM = SLAMCH( 'Safe minimum' ) / 512 + IF( IUPLO.EQ.1 ) THEN + I1 = N - 1 + ELSE + I1 = 1 + END IF + I2 = I1 + 1 + CALL SSCAL( N, SUBNRM, A( I1 ), LDA ) + CALL SSCAL( N, SUBNRM, A( I2 ), LDA ) + CALL SSCAL( N, SUBNRM, A( ( I1-1 )*LDA+1 ), 1 ) + CALL SSCAL( N, SUBNRM, A( ( I2-1 )*LDA+1 ), 1 ) + A( ( I1-1 )*LDA+I1 ) = SUBNRM + A( ( I2-1 )*LDA+I2 ) = SUBNRM + A( ( I2-1 )*LDA+I1 ) = FOUR*SUBNRM + A( ( I1-1 )*LDA+I2 ) = FOUR*SUBNRM + IZERO = 0 + END IF +* * End generate the test matrix A. * * @@ -439,7 +472,7 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * * Set the condition estimate flag if the INFO is not 0. * - IF( INFO.NE.0 ) THEN + IF( INFO.NE.0 .OR. IMAT.EQ.11 ) THEN TRFCON = .TRUE. ELSE TRFCON = .FALSE. @@ -484,7 +517,8 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * the threshold. * DO 110 K = 1, NT - IF( RESULT( K ).GE.THRESH ) THEN + IF( RESULT( K ).GE.THRESH .OR. + $ SISNAN( RESULT( K ) ) ) THEN IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) $ CALL ALAHD( NOUT, PATH ) WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, @@ -622,6 +656,8 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * Get an estimate of RCOND = 1/CNDNUM. * 140 CONTINUE + IF( IMAT.EQ.11 ) + $ GO TO 150 ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK ) SRNAMT = 'SSYCON' CALL SSYCON( UPLO, N, AFAC, LDA, IWORK, ANORM, RCOND, @@ -654,10 +690,69 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 170 CONTINUE 180 CONTINUE * +* +* Check an exact zero pivot created by updating a rank-one block +* when the singular matrix tests are requested. +* Unlike a row that is zero on input, its original diagonal must +* be replaced by the updated zero before returning the factors. +* + IF( .NOT.DOTYPE( 3 ) ) GO TO 260 + DO 250 IN = 1, NN + N = NVAL( IN ) + IF( N.LT.3 ) GO TO 250 + LDA = N + DO 240 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) + I1 = 1 + IF( IUPLO.EQ.1 ) I1 = N - 1 + I2 = I1 + 1 + IZERO = I2 + IF( IUPLO.EQ.1 ) IZERO = I1 + DO 230 MODE = 1, 1 + DO 200 J = 1, N + DO 190 I = 1, N + A( I+( J-1 )*LDA ) = ZERO + 190 CONTINUE + A( J+( J-1 )*LDA ) = 1.0E+0 + 200 CONTINUE + A( I1+( I1-1 )*LDA ) = 0.0625E+0 + A( I2+( I2-1 )*LDA ) = 0.0625E+0 + A( I1+( I2-1 )*LDA ) = 0.0625E+0 + A( I2+( I1-1 )*LDA ) = 0.0625E+0 + DO 220 INB = 1, NNB + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'SSYTRF' + CALL SSYTRF( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) + IF( INFO.NE.IZERO ) + $ CALL ALAERH( PATH, 'SSYTRF', INFO, IZERO, + $ UPLO, N, N, -1, -1, NB, 3, NFAIL, + $ NERRS, NOUT ) + CALL SSYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + IF( RESULT( 1 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9996 )UPLO, N, NB, MODE, + $ RESULT( 1 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE +* * Print a summary of the results. * CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) * + 9996 FORMAT( ' Zero pivot: UPLO = ''', A1, ''', N =', I5, + $ ', NB =', I4, ', mode =', I2, ', ratio =', G12.5 ) 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', $ I2, ', test ', I2, ', ratio =', G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', diff --git a/lapack-netlib/TESTING/dtest.in b/lapack-netlib/TESTING/dtest.in index cde62db50d..34a6dd14b2 100644 --- a/lapack-netlib/TESTING/dtest.in +++ b/lapack-netlib/TESTING/dtest.in @@ -22,7 +22,7 @@ DPS 9 List types on next line if 0 < NTYPES < 9 DPP 9 List types on next line if 0 < NTYPES < 9 DPB 8 List types on next line if 0 < NTYPES < 8 DPT 12 List types on next line if 0 < NTYPES < 12 -DSY 10 List types on next line if 0 < NTYPES < 10 +DSY 11 List types on next line if 0 < NTYPES < 11 DSR 10 List types on next line if 0 < NTYPES < 10 DSK 10 List types on next line if 0 < NTYPES < 10 DSA 10 List types on next line if 0 < NTYPES < 10 diff --git a/lapack-netlib/TESTING/stest.in b/lapack-netlib/TESTING/stest.in index abfd639fda..b95b4ed322 100644 --- a/lapack-netlib/TESTING/stest.in +++ b/lapack-netlib/TESTING/stest.in @@ -22,7 +22,7 @@ SPS 9 List types on next line if 0 < NTYPES < 9 SPP 9 List types on next line if 0 < NTYPES < 9 SPB 8 List types on next line if 0 < NTYPES < 8 SPT 12 List types on next line if 0 < NTYPES < 12 -SSY 10 List types on next line if 0 < NTYPES < 10 +SSY 11 List types on next line if 0 < NTYPES < 11 SSR 10 List types on next line if 0 < NTYPES < 10 SSK 10 List types on next line if 0 < NTYPES < 10 SSA 10 List types on next line if 0 < NTYPES < 10