diff --git a/lapack-netlib/SRC/Makefile b/lapack-netlib/SRC/Makefile index 511113028b..d602a95dbb 100644 --- a/lapack-netlib/SRC/Makefile +++ b/lapack-netlib/SRC/Makefile @@ -185,7 +185,7 @@ SLASRC_O = \ slarz.o slarzb.o slarzt.o slaswp.o slasy2.o slasyf.o slasyf_rook.o \ slasyf_rk.o \ slatbs.o slatdf.o slatps.o slatrd.o slatrs.o slatrz.o \ - slauu2.o slauum.o sopgtr.o sopmtr.o sorg2l.o sorg2r.o \ + slauu2.o slauum.o slauum_blocked.o slauum_recursive.o sopgtr.o sopmtr.o sorg2l.o sorg2r.o \ sorgbr.o sorghr.o sorgl2.o sorglq.o sorgql.o sorgqr.o sorgr2.o \ sorgrq.o sorgtr.o sorgtsqr.o sorgtsqr_row.o sorm2l.o sorm2r.o sorm22.o \ sormbr.o sormhr.o sorml2.o sormlq.o sormql.o sormqr.o sormr2.o \ @@ -235,7 +235,8 @@ SLASRC_O = \ ssbev_2stage.o ssbevx_2stage.o ssbevd_2stage.o ssygv_2stage.o \ sgesvdq.o slatrs3.o strsyl3.o sgelst.o sgedmd.o sgedmdq.o sgecxx.o \ sbdsvdmr3.o sbdsvdmr3_work.o sbdtgk.o sgesvdmr3.o slar1v_tgk.o \ - slarrb_tgk.o slarrf_tgk.o slarrv_tgk.o + slarrb_tgk.o slarrf_tgk.o slarrv_tgk.o slaed0_br.o slaed0_merge_pair.o \ + slaed4_br.o slaed7_br.o slaed8_br.o slaed9_br.o sstebr.o ssteqr_boundary_br.o endif ifneq "$(or $(BUILD_SINGLE),$(BUILD_DOUBLE))" "" @@ -303,7 +304,7 @@ CLASRC_O = \ clarz.o clarzb.o clarzt.o clascl.o claset.o clasr.o classq.o \ claswp.o clasyf.o clasyf_rook.o clasyf_rk.o clasyf_aa.o \ clatbs.o clatdf.o clatps.o clatrd.o clatrs.o clatrz.o \ - clauu2.o clauum.o cpbcon.o cpbequ.o cpbrfs.o cpbstf.o cpbsv.o \ + clauu2.o clauum.o clauum_blocked.o clauum_recursive.o cpbcon.o cpbequ.o cpbrfs.o cpbstf.o cpbsv.o \ cpbsvx.o cpbtf2.o cpbtrf.o cpbtrs.o cpocon.o cpoequ.o cporfs.o \ cposv.o cposvx.o cpotf2.o cpotri.o cpstrf.o cpstf2.o \ cppcon.o cppequ.o cpprfs.o cppsv.o cppsvx.o cpptrf.o cpptri.o cpptrs.o \ @@ -397,7 +398,7 @@ DLASRC_O = \ dlarz.o dlarzb.o dlarzt.o dlaswp.o dlasy2.o \ dlasyf.o dlasyf_rook.o dlasyf_rk.o \ dlatbs.o dlatdf.o dlatps.o dlatrd.o dlatrs.o dlatrz.o dlauu2.o \ - dlauum.o dopgtr.o dopmtr.o dorg2l.o dorg2r.o \ + dlauum.o dlauum_blocked.o dlauum_recursive.o dopgtr.o dopmtr.o dorg2l.o dorg2r.o \ dorgbr.o dorghr.o dorgl2.o dorglq.o dorgql.o dorgqr.o dorgr2.o \ dorgrq.o dorgtr.o dorgtsqr.o dorgtsqr_row.o dorm2l.o dorm2r.o dorm22.o \ dormbr.o dormhr.o dorml2.o dormlq.o dormql.o dormqr.o dormr2.o \ @@ -448,7 +449,8 @@ DLASRC_O = \ dsbev_2stage.o dsbevx_2stage.o dsbevd_2stage.o dsygv_2stage.o \ dgesvdq.o dlatrs3.o dtrsyl3.o dgelst.o dgedmd.o dgedmdq.o dgecxx.o \ dbdsvdmr3.o dbdsvdmr3_work.o dbdtgk.o dgesvdmr3.o dlar1v_tgk.o \ - dlarrb_tgk.o dlarrf_tgk.o dlarrv_tgk.o + dlarrb_tgk.o dlarrf_tgk.o dlarrv_tgk.o dlaed0_br.o dlaed0_merge_pair.o \ + dlaed4_br.o dlaed7_br.o dlaed8_br.o dlaed9_br.o dstebr.o dsteqr_boundary_br.o endif ifdef USEXBLAS @@ -514,7 +516,7 @@ ZLASRC_O = \ zlarz.o zlarzb.o zlarzt.o zlascl.o zlaset.o zlasr.o \ zlassq.o zlaswp.o zlasyf.o zlasyf_rook.o zlasyf_rk.o zlasyf_aa.o \ zlatbs.o zlatdf.o zlatps.o zlatrd.o zlatrs.o zlatrz.o zlauu2.o \ - zlauum.o zpbcon.o zpbequ.o zpbrfs.o zpbstf.o zpbsv.o \ + zlauum.o zlauum_blocked.o zlauum_recursive.o zpbcon.o zpbequ.o zpbrfs.o zpbstf.o zpbsv.o \ zpbsvx.o zpbtf2.o zpbtrf.o zpbtrs.o zpocon.o zpoequ.o zporfs.o \ zposv.o zposvx.o zpotf2.o zpotrf.o zpotri.o zpotrs.o zpstrf.o zpstf2.o \ zppcon.o zppequ.o zpprfs.o zppsv.o zppsvx.o zpptrf.o zpptri.o zpptrs.o \ @@ -610,26 +612,30 @@ DZL_AUX_OBJS = dlaed3.o SLAPACKOBJS = \ sgetrf.o sgetrs.o spotrf.o sgetf2.o \ spotf2.o slaswp.o sgesv.o slauu2.o \ - slauum.o strti2.o strtri.o strtrs.o \ - ssymv.o ssyr.o sspmv.o sspr.o + slauum.o slauum_blocked.o slauum_recursive.o \ + strti2.o strtri.o strtrs.o \ + ssymv.o ssyr.o sspmv.o sspr.o DLAPACKOBJS = \ dgetrf.o dgetrs.o dpotrf.o dgetf2.o \ dpotf2.o dlaswp.o dgesv.o dlauu2.o \ - dlauum.o dtrti2.o dtrtri.o dtrtrs.o \ - dsymv.o dsyr.o dspmv.o dspr.o + dlauum.o dlauum_blocked.o dlauum_recursive.o \ + dtrti2.o dtrtri.o dtrtrs.o \ + dsymv.o dsyr.o dspmv.o dspr.o CLAPACKOBJS = \ cgetrf.o cgetrs.o cpotrf.o cgetf2.o \ cpotf2.o claswp.o cgesv.o clauu2.o \ - clauum.o ctrti2.o ctrtri.o ctrtrs.o \ - csymv.o csyr.o cspmv.o cspr.o + clauum.o clauum_blocked.o clauum_recursive.o \ + ctrti2.o ctrtri.o ctrtrs.o \ + csymv.o csyr.o cspmv.o cspr.o ZLAPACKOBJS = \ zgetrf.o zgetrs.o zpotrf.o zgetf2.o \ zpotf2.o zlaswp.o zgesv.o zlauu2.o \ - zlauum.o ztrti2.o ztrtri.o ztrtrs.o \ - zsymv.o zsyr.o zspmv.o zspr.o + zlauum.o zlauum_blocked.o zlauum_recursive.o \ + ztrti2.o ztrtri.o ztrtrs.o \ + zsymv.o zsyr.o zspmv.o zspr.o ALLAUX = $(filter-out $(ALL_AUX_OBJS),$(ALLAUX_O)) SCLAUX = $(filter-out $(SCL_AUX_OBJS),$(SCLAUX_O)) diff --git a/lapack-netlib/SRC/clauu2.c b/lapack-netlib/SRC/clauu2.c index 047ce046ab..528e24d614 100644 --- a/lapack-netlib/SRC/clauu2.c +++ b/lapack-netlib/SRC/clauu2.c @@ -411,9 +411,6 @@ static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integ -lf2c -lm (in that order) */ - - - /* Table of constant values */ static complex c_b1 = {1.f,0.f}; @@ -427,7 +424,6 @@ nblocked algorithm). */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download CLAUU2 + dependencies */ /* > */ @@ -438,7 +434,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -492,7 +487,9 @@ f"> */ /* > On exit, if UPLO = 'U', the upper triangle of A is */ /* > overwritten with the upper triangle of the product U * U**H; */ /* > if UPLO = 'L', the lower triangle of A is overwritten with */ -/* > the lower triangle of the product L**H * L. */ +/* > the lower triangle of the product L**H * L. Regardless, */ +/* > the diagonal elements are explicitly set to be real by casting */ +/* . to REAL before exit. */ /* > \endverbatim */ /* > */ /* > \param[in] LDA */ @@ -516,9 +513,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complexOTHERauxiliary */ +/* > \ingroup lauu2 */ /* ===================================================================== */ /* Subroutine */ void clauu2_(char *uplo, integer *n, complex *a, integer *lda, @@ -526,28 +521,24 @@ f"> */ { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; - real r__1=0.; - complex q__1={0.,0.}; + real r__1; + complex q__1; /* Local variables */ - integer i__; - extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer - *, complex *, integer *); + integer i__, j; + complex aii, ajj; + extern /* Subroutine */ void cscal_(integer *, complex *, complex *, + integer *), cgemm_(char *, char *, integer *, integer *, integer * + , complex *, complex *, integer *, complex *, integer *, complex * + , complex *, integer *); extern logical lsame_(char *, char *); - extern /* Subroutine */ void cgemv_(char *, integer *, integer *, complex * - , complex *, integer *, complex *, integer *, complex *, complex * - , integer *); logical upper; - extern /* Subroutine */ void clacgv_(integer *, complex *, integer *), - csscal_(integer *, real *, complex *, integer *); - extern void xerbla_(char *, integer *, ftnlen); - real aii; + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); -/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK auxiliary 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 +548,7 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ @@ -587,30 +578,30 @@ f"> */ /* Compute the product U * U**H. */ i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__ + i__ * a_dim1; - aii = a[i__2].r; - if (i__ < *n) { - i__2 = i__ + i__ * a_dim1; - i__3 = *n - i__; - cdotc_(&q__1, &i__3, &a[i__ + (i__ + 1) * a_dim1], lda, &a[ - i__ + (i__ + 1) * a_dim1], lda); - r__1 = aii * aii + q__1.r; - a[i__2].r = r__1, a[i__2].i = 0.f; - i__2 = *n - i__; - clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); - i__2 = i__ - 1; - i__3 = *n - i__; - q__1.r = aii, q__1.i = 0.f; - cgemv_("No transpose", &i__2, &i__3, &c_b1, &a[(i__ + 1) * - a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, & - q__1, &a[i__ * a_dim1 + 1], &c__1); - i__2 = *n - i__; - clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); + for (j = 1; j <= i__1; ++j) { + r_cnjg(&q__1, &a[j + j * a_dim1]); + ajj.r = q__1.r, ajj.i = q__1.i; + if (j == *n) { + +/* We have this case separate just to ensure we never */ +/* access A out of bounds when we do A(J,J+1) = A(N,N+1) */ + + cscal_(n, &ajj, &a[*n * a_dim1 + 1], &c__1); } else { - csscal_(&i__, &aii, &a[i__ * a_dim1 + 1], &c__1); + i__2 = *n - j; + cgemm_("No Transpose", "Conjugate Transpose", &j, &c__1, & + i__2, &c_b1, &a[(j + 1) * a_dim1 + 1], lda, &a[j + (j + + 1) * a_dim1], lda, &ajj, &a[j * a_dim1 + 1], lda); } -/* L10: */ + +/* Since in exact arithmetic the diagonal will be real on output */ +/* we explicitly cast the diagonal to real (zero out the */ +/* imaginary component) */ + + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + r__1 = a[i__3].r; + a[i__2].r = r__1, a[i__2].i = 0.f; } } else { @@ -619,29 +610,29 @@ f"> */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__ + i__ * a_dim1; - aii = a[i__2].r; - if (i__ < *n) { - i__2 = i__ + i__ * a_dim1; - i__3 = *n - i__; - cdotc_(&q__1, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[ - i__ + 1 + i__ * a_dim1], &c__1); - r__1 = aii * aii + q__1.r; - a[i__2].r = r__1, a[i__2].i = 0.f; - i__2 = i__ - 1; - clacgv_(&i__2, &a[i__ + a_dim1], lda); - i__2 = *n - i__; - i__3 = i__ - 1; - q__1.r = aii, q__1.i = 0.f; - cgemv_("Conjugate transpose", &i__2, &i__3, &c_b1, &a[i__ + 1 - + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, & - q__1, &a[i__ + a_dim1], lda); - i__2 = i__ - 1; - clacgv_(&i__2, &a[i__ + a_dim1], lda); + r_cnjg(&q__1, &a[i__ + i__ * a_dim1]); + aii.r = q__1.r, aii.i = q__1.i; + if (i__ == *n) { + +/* We have this case separate just to ensure we never */ +/* access A out of bounds when we do A(I+1,I) = A(N+1,N) */ + + cscal_(n, &aii, &a[*n + a_dim1], lda); } else { - csscal_(&i__, &aii, &a[i__ + a_dim1], lda); + i__2 = *n - i__; + cgemm_("Conjugate Transpose", "No Transpose", &c__1, &i__, & + i__2, &c_b1, &a[i__ + 1 + i__ * a_dim1], lda, &a[i__ + + 1 + a_dim1], lda, &aii, &a[i__ + a_dim1], lda); } -/* L20: */ + +/* Since in exact arithmetic the diagonal will be real on output */ +/* we explicitly cast the diagonal to real (zero out the */ +/* imaginary component) */ + + i__2 = i__ + i__ * a_dim1; + i__3 = i__ + i__ * a_dim1; + r__1 = a[i__3].r; + a[i__2].r = r__1, a[i__2].i = 0.f; } } diff --git a/lapack-netlib/SRC/clauu2.f b/lapack-netlib/SRC/clauu2.f index 240ec20c08..bb6762dc72 100644 --- a/lapack-netlib/SRC/clauu2.f +++ b/lapack-netlib/SRC/clauu2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CLAUU2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -71,7 +69,9 @@ *> On exit, if UPLO = 'U', the upper triangle of A is *> overwritten with the upper triangle of the product U * U**H; *> if UPLO = 'L', the lower triangle of A is overwritten with -*> the lower triangle of the product L**H * L. +*> the lower triangle of the product L**H * L. Regardless, +*> the diagonal elements are explicitly set to be real by casting +*. to REAL before exit. *> \endverbatim *> *> \param[in] LDA @@ -95,10 +95,11 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexOTHERauxiliary +*> \ingroup lauu2 * * ===================================================================== SUBROUTINE CLAUU2( UPLO, N, A, LDA, INFO ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -120,19 +121,18 @@ SUBROUTINE CLAUU2( UPLO, N, A, LDA, INFO ) * .. * .. Local Scalars .. LOGICAL UPPER - INTEGER I - REAL AII + INTEGER I, J + COMPLEX AII, AJJ * .. * .. External Functions .. LOGICAL LSAME - COMPLEX CDOTC - EXTERNAL LSAME, CDOTC + EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL CGEMV, CLACGV, CSSCAL, XERBLA + EXTERNAL CGEMM, CSCAL, XERBLA * .. * .. Intrinsic Functions .. - INTRINSIC CMPLX, MAX, REAL + INTRINSIC CONJG, MAX, REAL * .. * .. Executable Statements .. * @@ -161,39 +161,51 @@ SUBROUTINE CLAUU2( UPLO, N, A, LDA, INFO ) * * Compute the product U * U**H. * - DO 10 I = 1, N - AII = REAL( A( I, I ) ) - IF( I.LT.N ) THEN - A( I, I ) = AII*AII + REAL( CDOTC( N-I, A( I, I+1 ), LDA, - $ A( I, I+1 ), LDA ) ) - CALL CLACGV( N-I, A( I, I+1 ), LDA ) - CALL CGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), - $ LDA, A( I, I+1 ), LDA, CMPLX( AII ), - $ A( 1, I ), 1 ) - CALL CLACGV( N-I, A( I, I+1 ), LDA ) + DO J = 1, N + AJJ = CONJG(A(J,J)) + IF( J.EQ.N ) THEN +* +* We have this case separate just to ensure we never +* access A out of bounds when we do A(J,J+1) = A(N,N+1) +* + CALL CSCAL( N, AJJ, A(1,N), 1 ) ELSE - CALL CSSCAL( I, AII, A( 1, I ), 1 ) + CALL CGEMM('No Transpose', 'Conjugate Transpose', + $ J, 1, N-J, ONE, A(1,J+1), LDA, A(J,J+1), LDA, + $ AJJ, A(1,J), LDA) END IF - 10 CONTINUE +* +* Since in exact arithmetic the diagonal will be real on output +* we explicitly cast the diagonal to real (zero out the +* imaginary component) +* + A(J,J) = REAL(A(J,J)) + END DO * ELSE * * Compute the product L**H * L. * - DO 20 I = 1, N - AII = REAL( A( I, I ) ) - IF( I.LT.N ) THEN - A( I, I ) = AII*AII + REAL( CDOTC( N-I, A( I+1, I ), 1, - $ A( I+1, I ), 1 ) ) - CALL CLACGV( I-1, A( I, 1 ), LDA ) - CALL CGEMV( 'Conjugate transpose', N-I, I-1, ONE, - $ A( I+1, 1 ), LDA, A( I+1, I ), 1, - $ CMPLX( AII ), A( I, 1 ), LDA ) - CALL CLACGV( I-1, A( I, 1 ), LDA ) + DO I = 1, N + AII = CONJG(A(I,I)) + IF( I.EQ.N ) THEN +* +* We have this case separate just to ensure we never +* access A out of bounds when we do A(I+1,I) = A(N+1,N) +* + CALL CSCAL(N, AII, A(N,1), LDA) ELSE - CALL CSSCAL( I, AII, A( I, 1 ), LDA ) + CALL CGEMM('Conjugate Transpose', 'No Transpose', + $ 1, I, N-I, ONE, A(I+1,I), LDA, A(I+1,1), LDA, + $ AII, A(I,1), LDA) END IF - 20 CONTINUE +* +* Since in exact arithmetic the diagonal will be real on output +* we explicitly cast the diagonal to real (zero out the +* imaginary component) +* + A(I,I) = REAL(A(I,I)) + END DO END IF * RETURN diff --git a/lapack-netlib/SRC/clauum.c b/lapack-netlib/SRC/clauum.c index b776abac94..a874b17f27 100644 --- a/lapack-netlib/SRC/clauum.c +++ b/lapack-netlib/SRC/clauum.c @@ -529,20 +529,14 @@ static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integ /* Table of constant values */ -static complex c_b1 = {1.f,0.f}; -static integer c__1 = 1; -static integer c_n1 = -1; -static real c_b21 = 1.f; - -/* > \brief \b CLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (b -locked algorithm). */ +/* > \brief \b CLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (d +river algorithm). */ /* =========== DOCUMENTATION =========== */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download CLAUUM + dependencies */ /* > */ @@ -553,7 +547,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -575,11 +568,13 @@ f"> */ /* > the array A. */ /* > */ /* > If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ -/* > overwriting the factor U in A. */ +/* > overwriting the factor U in A, and the strictly lower triangular part */ +/* > of A is not referenced. */ /* > If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ -/* > overwriting the factor L in A. */ +/* > overwriting the factor L in A, and the strictly upper triangular part */ +/* > of A is not referenced. */ /* > */ -/* > This is the blocked form of the algorithm, calling Level 3 BLAS. */ +/* > This is the driver that dispatches to either blocked or recursive */ /* > \endverbatim */ /* Arguments: */ @@ -605,9 +600,13 @@ f"> */ /* > A is COMPLEX array, dimension (LDA,N) */ /* > On entry, the triangular factor U or L. */ /* > On exit, if UPLO = 'U', the upper triangle of A is */ -/* > overwritten with the upper triangle of the product U * U**H; */ -/* > if UPLO = 'L', the lower triangle of A is overwritten with */ -/* > the lower triangle of the product L**H * L. */ +/* > overwritten with the upper triangle of the product U * U**H, */ +/* > and the strictly lower triangular part of A is not referenced. */ +/* > If UPLO = 'L', the lower triangle of A is overwritten with */ +/* > the lower triangle of the product L**H * L, and the strictly upper */ +/* > triangular part of A is not referenced. Regardless, */ +/* > the diagonal elements are explicitly set to be real by casting */ +/* . to REAL before exit. */ /* > \endverbatim */ /* > */ /* > \param[in] LDA */ @@ -631,41 +630,25 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complexOTHERauxiliary */ +/* > \ingroup lauum */ /* ===================================================================== */ /* Subroutine */ void clauum_(char *uplo, integer *n, complex *a, integer *lda, 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; /* Local variables */ - integer i__; - extern /* Subroutine */ void cgemm_(char *, char *, integer *, integer *, - integer *, complex *, complex *, integer *, complex *, integer *, - complex *, complex *, integer *), cherk_(char *, - char *, integer *, integer *, real *, complex *, integer *, real * - , complex *, integer *); extern logical lsame_(char *, char *); - extern /* Subroutine */ void ctrmm_(char *, char *, char *, char *, - integer *, integer *, complex *, complex *, integer *, complex *, - integer *); logical upper; - extern /* Subroutine */ void clauu2_(char *, integer *, complex *, integer - *, integer *); - integer ib, nb; - extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), clauum_recursive_( + char *, integer *, complex *, integer *, integer *); -/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK auxiliary routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -675,7 +658,7 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ @@ -700,81 +683,14 @@ f"> */ return; } -/* Determine the block size for this environment. */ - - nb = ilaenv_(&c__1, "CLAUUM", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( - ftnlen)1); - - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code */ - - clauu2_(uplo, n, &a[a_offset], lda, info); - } else { - -/* Use blocked code */ - - if (upper) { - -/* Compute the product U * U**H. */ - - i__1 = *n; - i__2 = nb; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__3 = nb, i__4 = *n - i__ + 1; - ib = f2cmin(i__3,i__4); - i__3 = i__ - 1; - ctrmm_("Right", "Upper", "Conjugate transpose", "Non-unit", & - i__3, &ib, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__ - * a_dim1 + 1], lda); - clauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); - if (i__ + ib <= *n) { - i__3 = i__ - 1; - i__4 = *n - i__ - ib + 1; - cgemm_("No transpose", "Conjugate transpose", &i__3, &ib, - &i__4, &c_b1, &a[(i__ + ib) * a_dim1 + 1], lda, & - a[i__ + (i__ + ib) * a_dim1], lda, &c_b1, &a[i__ * - a_dim1 + 1], lda); - i__3 = *n - i__ - ib + 1; - cherk_("Upper", "No transpose", &ib, &i__3, &c_b21, &a[ - i__ + (i__ + ib) * a_dim1], lda, &c_b21, &a[i__ + - i__ * a_dim1], lda); - } -/* L10: */ - } - } else { - -/* Compute the product L**H * L. */ - - i__2 = *n; - i__1 = nb; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { -/* Computing MIN */ - i__3 = nb, i__4 = *n - i__ + 1; - ib = f2cmin(i__3,i__4); - i__3 = i__ - 1; - ctrmm_("Left", "Lower", "Conjugate transpose", "Non-unit", & - ib, &i__3, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__ - + a_dim1], lda); - clauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); - if (i__ + ib <= *n) { - i__3 = i__ - 1; - i__4 = *n - i__ - ib + 1; - cgemm_("Conjugate transpose", "No transpose", &ib, &i__3, - &i__4, &c_b1, &a[i__ + ib + i__ * a_dim1], lda, & - a[i__ + ib + a_dim1], lda, &c_b1, &a[i__ + a_dim1] - , lda); - i__3 = *n - i__ - ib + 1; - cherk_("Lower", "Conjugate transpose", &ib, &i__3, &c_b21, - &a[i__ + ib + i__ * a_dim1], lda, &c_b21, &a[i__ - + i__ * a_dim1], lda); - } -/* L20: */ - } - } - } +/* Here we dispatch to whatever is more efficient in a particular environment */ +/* We are defaulting to recursive, but if you want to use the blocked variant */ +/* Comment out the line starting with `CALL CLAUUM_...` */ +/* and uncomment the line starting with `CALL CLAUUM_BLOCKED...` */ + clauum_recursive_(uplo, n, &a[a_offset], lda, info); + //clauum_blocked_(uplo, n, &a[a_offset], lda, info); +/* CALL CLAUUM_BLOCKED(UPLO, N, A, LDA, INFO) */ return; /* End of CLAUUM */ diff --git a/lapack-netlib/SRC/clauum.f b/lapack-netlib/SRC/clauum.f index 8b3cbc51dd..cd095bca7f 100644 --- a/lapack-netlib/SRC/clauum.f +++ b/lapack-netlib/SRC/clauum.f @@ -1,11 +1,10 @@ -*> \brief \b CLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm). +*> \brief \b CLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (driver algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CLAUUM + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -39,11 +37,13 @@ *> the array A. *> *> If UPLO = 'U' or 'u' then the upper triangle of the result is stored, -*> overwriting the factor U in A. +*> overwriting the factor U in A, and the strictly lower triangular part +*> of A is not referenced. *> If UPLO = 'L' or 'l' then the lower triangle of the result is stored, -*> overwriting the factor L in A. +*> overwriting the factor L in A, and the strictly upper triangular part +*> of A is not referenced. *> -*> This is the blocked form of the algorithm, calling Level 3 BLAS. +*> This is the driver that dispatches to either blocked or recursive *> \endverbatim * * Arguments: @@ -69,9 +69,13 @@ *> A is COMPLEX array, dimension (LDA,N) *> On entry, the triangular factor U or L. *> On exit, if UPLO = 'U', the upper triangle of A is -*> overwritten with the upper triangle of the product U * U**H; -*> if UPLO = 'L', the lower triangle of A is overwritten with -*> the lower triangle of the product L**H * L. +*> overwritten with the upper triangle of the product U * U**H, +*> and the strictly lower triangular part of A is not referenced. +*> If UPLO = 'L', the lower triangle of A is overwritten with +*> the lower triangle of the product L**H * L, and the strictly upper +*> triangular part of A is not referenced. Regardless, +*> the diagonal elements are explicitly set to be real by casting +*. to REAL before exit. *> \endverbatim *> *> \param[in] LDA @@ -95,10 +99,11 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexOTHERauxiliary +*> \ingroup lauum * * ===================================================================== SUBROUTINE CLAUUM( UPLO, N, A, LDA, INFO ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -114,26 +119,20 @@ SUBROUTINE CLAUUM( UPLO, N, A, LDA, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) - COMPLEX CONE - PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. LOGICAL UPPER - INTEGER I, IB, NB * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV + EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL CGEMM, CHERK, CLAUU2, CTRMM, XERBLA + EXTERNAL XERBLA, CLAUUM_RECURSIVE, + $ CLAUUM_BLOCKED * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN + INTRINSIC MAX * .. * .. Executable Statements .. * @@ -158,61 +157,13 @@ SUBROUTINE CLAUUM( UPLO, N, A, LDA, INFO ) IF( N.EQ.0 ) $ RETURN * -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'CLAUUM', UPLO, N, -1, -1, -1 ) -* - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL CLAUU2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute the product U * U**H. -* - DO 10 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Non-unit', I-1, IB, CONE, A( I, I ), LDA, - $ A( 1, I ), LDA ) - CALL CLAUU2( 'Upper', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL CGEMM( 'No transpose', 'Conjugate transpose', - $ I-1, IB, N-I-IB+1, CONE, A( 1, I+IB ), - $ LDA, A( I, I+IB ), LDA, CONE, A( 1, I ), - $ LDA ) - CALL CHERK( 'Upper', 'No transpose', IB, N-I-IB+1, - $ ONE, A( I, I+IB ), LDA, ONE, A( I, I ), - $ LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the product L**H * L. -* - DO 20 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL CTRMM( 'Left', 'Lower', 'Conjugate transpose', - $ 'Non-unit', IB, I-1, CONE, A( I, I ), LDA, - $ A( I, 1 ), LDA ) - CALL CLAUU2( 'Lower', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL CGEMM( 'Conjugate transpose', 'No transpose', IB, - $ I-1, N-I-IB+1, CONE, A( I+IB, I ), LDA, - $ A( I+IB, 1 ), LDA, CONE, A( I, 1 ), LDA ) - CALL CHERK( 'Lower', 'Conjugate transpose', IB, - $ N-I-IB+1, ONE, A( I+IB, I ), LDA, ONE, - $ A( I, I ), LDA ) - END IF - 20 CONTINUE - END IF - END IF +* Here we dispatch to whatever is more efficient in a particular environment +* We are defaulting to recursive, but if you want to use the blocked variant +* Comment out the line starting with `CALL CLAUUM_RECURSIVE...` +* and uncomment the line starting with `CALL CLAUUM_BLOCKED...` * + CALL CLAUUM_RECURSIVE(UPLO, N, A, LDA, INFO) +* CALL CLAUUM_BLOCKED(UPLO, N, A, LDA, INFO) RETURN * * End of CLAUUM diff --git a/lapack-netlib/SRC/clauum_blocked.c b/lapack-netlib/SRC/clauum_blocked.c new file mode 100644 index 0000000000..019a72f5da --- /dev/null +++ b/lapack-netlib/SRC/clauum_blocked.c @@ -0,0 +1,772 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#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));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#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)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#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 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 + +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 \brief \b CLAUUM_BLOCKED computes the product UUH or LHL, where U and L are upper or lower triangular mat +rices (blocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLAUUM_BLOCKED( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLAUUM_BLOCKED computes the product U * U**H or L**H * L, where the triangular */ +/* > factor U or L is stored in the upper or lower triangular part of */ +/* > the array A. */ +/* > */ +/* > If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ +/* > overwriting the factor U in A, and the strictly lower triangular part */ +/* > of A is not referenced. */ +/* > If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ +/* > overwriting the factor L in A, and the strictly upper triangular part */ +/* > of A is not referenced. */ +/* > */ +/* > This is the blocked form of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the triangular factor stored in the array A */ +/* > is upper or lower triangular: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the triangular factor U or L. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the triangular factor U or L. */ +/* > On exit, if UPLO = 'U', the upper triangle of A is */ +/* > overwritten with the upper triangle of the product U * U**H, */ +/* > and the strictly lower triangular part of A is not referenced. */ +/* > If UPLO = 'L', the lower triangle of A is overwritten with */ +/* > the lower triangle of the product L**H * L, and the strictly */ +/* > upper triangular part of A is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup lauum */ + +/* ===================================================================== */ +/* Subroutine */ void clauum_blocked_(char *uplo, integer *n, complex *a, + integer *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, ib, nb; + extern /* Subroutine */ void cgemm_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *), cherk_(char *, + char *, integer *, integer *, real *, complex *, integer *, real * + , complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ void ctrmm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + logical upper; + extern /* Subroutine */ void clauu2_(char *, integer *, complex *, integer + *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + +/* -- LAPACK auxiliary routine -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLAUUM_BLOCKED", &i__1, (ftnlen)14); + return; + } + +/* Quick return if possible */ + + if (*n == 0) { + return; + } + +/* Determine the block size for this environment. */ + + nb = ilaenv_(&c__1, "CLAUUM_BLOCKED", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)14, (ftnlen)1); + + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + clauu2_(uplo, n, &a[a_offset], lda, info); + } else { + +/* Use blocked code */ + + if (upper) { + +/* Compute the product U * U**H. */ + + i__1 = *n; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - i__ + 1; + ib = f2cmin(i__3,i__4); + i__3 = i__ - 1; + ctrmm_("Right", "Upper", "Conjugate transpose", "Non-unit", & + i__3, &ib, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__ + * a_dim1 + 1], lda); + clauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); + if (i__ + ib <= *n) { + i__3 = i__ - 1; + i__4 = *n - i__ - ib + 1; + cgemm_("No transpose", "Conjugate transpose", &i__3, &ib, + &i__4, &c_b1, &a[(i__ + ib) * a_dim1 + 1], lda, & + a[i__ + (i__ + ib) * a_dim1], lda, &c_b1, &a[i__ * + a_dim1 + 1], lda); + i__3 = *n - i__ - ib + 1; + cherk_("Upper", "No transpose", &ib, &i__3, &c_b21, &a[ + i__ + (i__ + ib) * a_dim1], lda, &c_b21, &a[i__ + + i__ * a_dim1], lda); + } +/* L10: */ + } + } else { + +/* Compute the product L**H * L. */ + + i__2 = *n; + i__1 = nb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - i__ + 1; + ib = f2cmin(i__3,i__4); + i__3 = i__ - 1; + ctrmm_("Left", "Lower", "Conjugate transpose", "Non-unit", & + ib, &i__3, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__ + + a_dim1], lda); + clauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); + if (i__ + ib <= *n) { + i__3 = i__ - 1; + i__4 = *n - i__ - ib + 1; + cgemm_("Conjugate transpose", "No transpose", &ib, &i__3, + &i__4, &c_b1, &a[i__ + ib + i__ * a_dim1], lda, & + a[i__ + ib + a_dim1], lda, &c_b1, &a[i__ + a_dim1] + , lda); + i__3 = *n - i__ - ib + 1; + cherk_("Lower", "Conjugate transpose", &ib, &i__3, &c_b21, + &a[i__ + ib + i__ * a_dim1], lda, &c_b21, &a[i__ + + i__ * a_dim1], lda); + } +/* L20: */ + } + } + } + + return; + +/* End of CLAUUM_BLOCKED */ + +} /* clauum_blocked__ */ + diff --git a/lapack-netlib/SRC/clauum_blocked.f b/lapack-netlib/SRC/clauum_blocked.f new file mode 100644 index 0000000000..424f54873f --- /dev/null +++ b/lapack-netlib/SRC/clauum_blocked.f @@ -0,0 +1,216 @@ +*> \brief \b CLAUUM_BLOCKED computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CLAUUM_BLOCKED( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLAUUM_BLOCKED computes the product U * U**H or L**H * L, where the triangular +*> factor U or L is stored in the upper or lower triangular part of +*> the array A. +*> +*> If UPLO = 'U' or 'u' then the upper triangle of the result is stored, +*> overwriting the factor U in A, and the strictly lower triangular part +*> of A is not referenced. +*> If UPLO = 'L' or 'l' then the lower triangle of the result is stored, +*> overwriting the factor L in A, and the strictly upper triangular part +*> of A is not referenced. +*> +*> This is the blocked form of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the triangular factor stored in the array A +*> is upper or lower triangular: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the triangular factor U or L. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the triangular factor U or L. +*> On exit, if UPLO = 'U', the upper triangle of A is +*> overwritten with the upper triangle of the product U * U**H, +*> and the strictly lower triangular part of A is not referenced. +*> If UPLO = 'L', the lower triangle of A is overwritten with +*> the lower triangle of the product L**H * L, and the strictly +*> upper triangular part of A is not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lauum +* +* ===================================================================== + SUBROUTINE CLAUUM_BLOCKED( UPLO, N, A, LDA, INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) + COMPLEX CONE + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IB, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CLAUU2, CTRMM, CGEMM, CHERK +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLAUUM_BLOCKED', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'CLAUUM_BLOCKED', UPLO, N, -1, -1, -1 ) +* + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL CLAUU2( UPLO, N, A, LDA, INFO ) + ELSE +* +* Use blocked code +* + IF( UPPER ) THEN +* +* Compute the product U * U**H. +* + DO 10 I = 1, N, NB + IB = MIN( NB, N-I+1 ) + CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', + $ 'Non-unit', I-1, IB, CONE, A( I, I ), LDA, + $ A( 1, I ), LDA ) + CALL CLAUU2( 'Upper', IB, A( I, I ), LDA, INFO ) + IF( I+IB.LE.N ) THEN + CALL CGEMM( 'No transpose', 'Conjugate transpose', + $ I-1, IB, N-I-IB+1, CONE, A( 1, I+IB ), + $ LDA, A( I, I+IB ), LDA, CONE, A( 1, I ), + $ LDA ) + CALL CHERK( 'Upper', 'No transpose', IB, N-I-IB+1, + $ ONE, A( I, I+IB ), LDA, ONE, A( I, I ), + $ LDA ) + END IF + 10 CONTINUE + ELSE +* +* Compute the product L**H * L. +* + DO 20 I = 1, N, NB + IB = MIN( NB, N-I+1 ) + CALL CTRMM( 'Left', 'Lower', 'Conjugate transpose', + $ 'Non-unit', IB, I-1, CONE, A( I, I ), LDA, + $ A( I, 1 ), LDA ) + CALL CLAUU2( 'Lower', IB, A( I, I ), LDA, INFO ) + IF( I+IB.LE.N ) THEN + CALL CGEMM( 'Conjugate transpose', 'No transpose', + $ IB, + $ I-1, N-I-IB+1, CONE, A( I+IB, I ), LDA, + $ A( I+IB, 1 ), LDA, CONE, A( I, 1 ), LDA ) + CALL CHERK( 'Lower', 'Conjugate transpose', IB, + $ N-I-IB+1, ONE, A( I+IB, I ), LDA, ONE, + $ A( I, I ), LDA ) + END IF + 20 CONTINUE + END IF + END IF +* + RETURN +* +* End of CLAUUM_BLOCKED +* + END diff --git a/lapack-netlib/SRC/clauum_recursive.c b/lapack-netlib/SRC/clauum_recursive.c new file mode 100644 index 0000000000..01806ff6ab --- /dev/null +++ b/lapack-netlib/SRC/clauum_recursive.c @@ -0,0 +1,834 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#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));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#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)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#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 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 + +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 \brief \b CLAUUM_ computes the product UUH or LHL, where U and L are upper or lower triangular matrices ( +recursive algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLAUUM_( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLAUUM_ computes the product U * U**H or L**H * L, where the triangular */ +/* > factor U or L is stored in the upper or lower triangular part of */ +/* > the array A. */ +/* > */ +/* > If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ +/* > overwriting the factor U in A, and the strictly lower triangular part */ +/* > of A is not referenced. */ +/* > If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ +/* > overwriting the factor L in A, and the strictly upper triangular part */ +/* > of A is not referenced. */ +/* > */ +/* > This is the recursive version of the algorithm */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the triangular factor stored in the array A */ +/* > is upper or lower triangular: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the triangular factor U or L. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the triangular factor U or L. */ +/* > On exit, if UPLO = 'U', the upper triangle of A is */ +/* > overwritten with the upper triangle of the product U * U**H, */ +/* > and the strictly lower triangular part of A is not referenced. */ +/* > If UPLO = 'L', the lower triangle of A is overwritten with */ +/* > the lower triangle of the product L**H * L, and the */ +/* > strictly upper triangular part of A is not referenced. Regardless, */ +/* > the diagonal elements are explicitly set to be real by casting */ +/* . to REAL before exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup lauum */ + +/* ===================================================================== */ +/* Subroutine */ void clauum_recursive_(char *uplo, integer *n, complex *a, integer * + lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + real r__1; + complex q__1, q__2; + + /* Local variables */ + integer k, nx; + extern /* Subroutine */ void cherk_(char *, char *, integer *, integer *, + real *, complex *, integer *, real *, complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ void ctrmm_(char *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *); + logical upper; + extern /* Subroutine */ void clauu2_(char *, integer *, complex *, integer + *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + +/* -- LAPACK auxiliary routine -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLAUUM_RECURSIVE", &i__1, (ftnlen)16); + return; + } + +/* Early termination criteria */ + + if (*n == 0) { + return; + } + +/* Base Case */ + + if (*n == 1) { + i__1 = a_dim1 + 1; + i__2 = a_dim1 + 1; + r_cnjg(&q__2, &a[a_dim1 + 1]); + q__1.r = a[i__2].r * q__2.r - a[i__2].i * q__2.i, q__1.i = a[i__2].r * + q__2.i + a[i__2].i * q__2.r; + r__1 = q__1.r; + a[i__1].r = r__1, a[i__1].i = 0.f; + return; + } + +/* Determine crossover point for when to bail to level2 */ + + nx = ilaenv_(&c__3, "CLAUUM_RECURSIVE", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)16, ( + ftnlen)1); + if (*n < nx) { + clauu2_(uplo, n, &a[a_offset], lda, info); + return; + } + +/* Beginning of executable statements for the recursive case */ + + k = *n / 2; + if (upper) { + +/* We are computing A = ut(U*U**H). */ + +/* Break apart U as follows */ +/* |-----------------| */ +/* U = | U_{11} U_{12} | */ +/* | 0 U_{22} | */ +/* |-----------------| */ + +/* Where */ +/* U_{11}\in\C^{k\times k} U_{12}\in\C^{ k\times n-k} */ +/* U_{22}\in\C^{n-k\times n-k} */ + +/* and U_{11},U_{22} are upper triangular and U_{12} is rectangular */ + +/* This gives us our operations as */ +/* |--------------------| |------------------------| */ +/* ut(U * U**H) = | U_{11} U_{12} | | U_{11}**H 0 | */ +/* | 0 U_{22} | | U_{12}**H U_{22}**H | */ +/* |--------------------| |------------------------| */ + +/* Thus we get */ + +/* U_{11} = U_{11}U_{11}**H + U_{12}U_{12}**H */ +/* U_{12} = U_{12}U_{22}**H */ + +/* U_{22} = U_{22}U_{22}**H */ + +/* We break these operations apart as follows */ + +/* U_{11} = U_{11}U_{11}**H (This subroutine) */ +/* U_{11} = U_{12}U_{12}**H + U_{11} (HERK) */ + +/* U_{12} = U_{12}U_{22}**H (TRMM) */ + +/* U_{22} = U_{22}U_{22}**H (This subroutine) */ + + +/* Compute U_{11} */ + + clauum_recursive_(uplo, &k, &a[a_offset], lda, info); + i__1 = *n - k; + cherk_("Upper", "No Transpose", &k, &i__1, &c_b13, &a[(k + 1) * + a_dim1 + 1], lda, &c_b13, &a[a_offset], lda); + +/* Compute U_{12} */ + + i__1 = *n - k; + ctrmm_("Right", "Upper", "Conjugate", "Non-unit", &k, &i__1, &c_b1, & + a[k + 1 + (k + 1) * a_dim1], lda, &a[(k + 1) * a_dim1 + 1], + lda); + +/* Compute U_{22} */ + + i__1 = *n - k; + clauum_recursive_(uplo, &i__1, &a[k + 1 + (k + 1) * a_dim1], lda, info); + } else { + +/* We are computing A = lt(L**H*L). */ + +/* Break apart L as follows */ +/* |-----------------| */ +/* L = | L_{11} 0 | */ +/* | L_{21} L_{22} | */ +/* |-----------------| */ + +/* Where */ +/* L_{11}\in\C^{ k\times k} */ +/* L_{21}\in\C^{n-k\times k} l_{22}\in\C^{n-k\times n-k} */ + +/* and L_{11},L_{22} are lower triangular and L_{21} is rectangular */ + +/* This gives us our operations as */ +/* |--------------------------| |-----------------| */ +/* lt(L**H * L) = | L_{11}**H L_{21}**H | | L_{11} 0 | */ +/* | 0 L_{22}**H | | L_{21} L_{22} | */ +/* |--------------------------| |-----------------| */ + +/* Thus we get */ + +/* L_{11} = L_{11}**H L_{11} + L_{21}**H L_{21} */ +/* L_{21} = L_{22}**H L_{21} */ + +/* L_{22} = L_{22}**H L_{22} */ + +/* We break these operations apart as follows */ + +/* L_{11} = L_{11}**H L_{11} (This subroutine) */ +/* L_{11} = L_{21}**H L_{21} + L_{11} (HERK) */ + +/* L_{21} = L_{22}**H L_{21} (TRMM) */ + +/* L_{22} = L_{22}**H L_{22} (This subroutine) */ + + +/* Compute L_{11} */ + + clauum_recursive_(uplo, &k, &a[a_offset], lda, info); + i__1 = *n - k; + cherk_("Lower", "Conjugate", &k, &i__1, &c_b13, &a[k + 1 + a_dim1], + lda, &c_b13, &a[a_offset], lda); + +/* Compute L_{21} */ + + i__1 = *n - k; + ctrmm_("Left", "Lower", "Conjugate", "Non-Unit", &i__1, &k, &c_b1, &a[ + k + 1 + (k + 1) * a_dim1], lda, &a[k + 1 + a_dim1], lda); + +/* Compute L_{22} */ + + i__1 = *n - k; + clauum_recursive_(uplo, &i__1, &a[k + 1 + (k + 1) * a_dim1], lda, info); + } + return; +} /* clauum___ */ + diff --git a/lapack-netlib/SRC/clauum_recursive.f b/lapack-netlib/SRC/clauum_recursive.f new file mode 100644 index 0000000000..92acfdf8bd --- /dev/null +++ b/lapack-netlib/SRC/clauum_recursive.f @@ -0,0 +1,283 @@ +*> \brief \b CLAUUM_RECURSIVE computes the product UUH or LHL, where U and L are upper or lower triangular matrices (recursive algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CLAUUM_RECURSIVE( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLAUUM_RECURSIVE computes the product U * U**H or L**H * L, where the triangular +*> factor U or L is stored in the upper or lower triangular part of +*> the array A. +*> +*> If UPLO = 'U' or 'u' then the upper triangle of the result is stored, +*> overwriting the factor U in A, and the strictly lower triangular part +*> of A is not referenced. +*> If UPLO = 'L' or 'l' then the lower triangle of the result is stored, +*> overwriting the factor L in A, and the strictly upper triangular part +*> of A is not referenced. +*> +*> This is the recursive version of the algorithm +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the triangular factor stored in the array A +*> is upper or lower triangular: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the triangular factor U or L. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the triangular factor U or L. +*> On exit, if UPLO = 'U', the upper triangle of A is +*> overwritten with the upper triangle of the product U * U**H, +*> and the strictly lower triangular part of A is not referenced. +*> If UPLO = 'L', the lower triangle of A is overwritten with +*> the lower triangle of the product L**H * L, and the +*> strictly upper triangular part of A is not referenced. Regardless, +*> the diagonal elements are explicitly set to be real by casting +*. to REAL before exit. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lauum +* +* ===================================================================== + RECURSIVE SUBROUTINE CLAUUM_RECURSIVE( UPLO, N, A, LDA, INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX CONE + REAL ONE + PARAMETER ( ONE = 1.0E+0, CONE = (1.0E+0, 0.0E+0) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, NX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CLAUU2, CHERK, CTRMM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, CONJG, REAL +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLAUUM_RECURSIVE', -INFO ) + RETURN + END IF +* +* Early termination criteria +* + IF( N.EQ.0 ) THEN + RETURN + END IF +* +* Base Case +* + IF( N.EQ.1 ) THEN + A(1,1) = REAL(A(1,1) * CONJG(A(1,1))) + RETURN + END IF +* +* Determine crossover point for when to bail to level2 +* + NX = ILAENV(3, "CLAUUM_RECURSIVE", UPLO, N, -1, -1, -1) + IF( N.LT.NX ) THEN + CALL CLAUU2(UPLO, N, A, LDA, INFO) + RETURN + END IF +* +* Beginning of executable statements for the recursive case +* + K = N/2 + IF( UPPER ) THEN +* +* We are computing A = ut(U*U**H). +* +* Break apart U as follows +* |-----------------| +* U = | U_{11} U_{12} | +* | 0 U_{22} | +* |-----------------| +* +* Where +* U_{11}\in\C^{k\times k} U_{12}\in\C^{ k\times n-k} +* U_{22}\in\C^{n-k\times n-k} +* +* and U_{11},U_{22} are upper triangular and U_{12} is rectangular +* +* This gives us our operations as +* |--------------------| |------------------------| +* ut(U * U**H) = | U_{11} U_{12} | | U_{11}**H 0 | +* | 0 U_{22} | | U_{12}**H U_{22}**H | +* |--------------------| |------------------------| +* +* Thus we get +* +* U_{11} = U_{11}U_{11}**H + U_{12}U_{12}**H +* U_{12} = U_{12}U_{22}**H +* +* U_{22} = U_{22}U_{22}**H +* +* We break these operations apart as follows +* +* U_{11} = U_{11}U_{11}**H (This subroutine) +* U_{11} = U_{12}U_{12}**H + U_{11} (HERK) +* +* U_{12} = U_{12}U_{22}**H (TRMM) +* +* U_{22} = U_{22}U_{22}**H (This subroutine) +* +* +* Compute U_{11} +* + CALL CLAUUM_RECURSIVE(UPLO, K, A, LDA, INFO) + CALL CHERK('Upper', 'No Transpose', K, N-K, + $ ONE, A(1,K+1), LDA, ONE, A, LDA) +* +* Compute U_{12} +* + CALL CTRMM('Right', 'Upper', 'Conjugate', 'Non-unit', + $ K, N-K, CONE, A(K+1,K+1), LDA, A(1,K+1), LDA) +* +* Compute U_{22} +* + CALL CLAUUM_RECURSIVE(UPLO, N-K, A(K+1,K+1), LDA, INFO) + ELSE +* +* We are computing A = lt(L**H*L). +* +* Break apart L as follows +* |-----------------| +* L = | L_{11} 0 | +* | L_{21} L_{22} | +* |-----------------| +* +* Where +* L_{11}\in\C^{ k\times k} +* L_{21}\in\C^{n-k\times k} l_{22}\in\C^{n-k\times n-k} +* +* and L_{11},L_{22} are lower triangular and L_{21} is rectangular +* +* This gives us our operations as +* |--------------------------| |-----------------| +* lt(L**H * L) = | L_{11}**H L_{21}**H | | L_{11} 0 | +* | 0 L_{22}**H | | L_{21} L_{22} | +* |--------------------------| |-----------------| +* +* Thus we get +* +* L_{11} = L_{11}**H L_{11} + L_{21}**H L_{21} +* L_{21} = L_{22}**H L_{21} +* +* L_{22} = L_{22}**H L_{22} +* +* We break these operations apart as follows +* +* L_{11} = L_{11}**H L_{11} (This subroutine) +* L_{11} = L_{21}**H L_{21} + L_{11} (HERK) +* +* L_{21} = L_{22}**H L_{21} (TRMM) +* +* L_{22} = L_{22}**H L_{22} (This subroutine) +* +* +* Compute L_{11} +* + CALL CLAUUM_RECURSIVE(UPLO, K, A, LDA, INFO) + CALL CHERK('Lower', 'Conjugate', K, N-K, + $ ONE, A(K+1,1), LDA, ONE, A, LDA) +* +* Compute L_{21} +* + CALL CTRMM('Left', 'Lower', 'Conjugate', 'Non-Unit', + $ N-K, K, CONE, A(K+1,K+1), LDA, A(K+1,1), LDA) +* +* Compute L_{22} +* + CALL CLAUUM_RECURSIVE(UPLO, N-K, A(K+1,K+1), LDA, INFO) + END IF + END SUBROUTINE diff --git a/lapack-netlib/SRC/dlauu2.c b/lapack-netlib/SRC/dlauu2.c index 278396e8c4..294c680360 100644 --- a/lapack-netlib/SRC/dlauu2.c +++ b/lapack-netlib/SRC/dlauu2.c @@ -228,6 +228,7 @@ typedef struct Namelist Namelist; + /* Table of constant values */ static doublereal c_b7 = 1.; @@ -241,7 +242,6 @@ nblocked algorithm). */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download DLAUU2 + dependencies */ /* > */ @@ -252,7 +252,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -330,9 +329,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup doubleOTHERauxiliary */ +/* > \ingroup lauu2 */ /* ===================================================================== */ /* Subroutine */ void dlauu2_(char *uplo, integer *n, doublereal *a, integer * @@ -342,9 +339,10 @@ f"> */ integer a_dim1, a_offset, i__1, i__2, i__3; /* Local variables */ + integer i__; + doublereal aii; extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); - integer i__; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); @@ -353,13 +351,11 @@ f"> */ doublereal *, doublereal *, integer *); logical upper; extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - doublereal aii; -/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK auxiliary routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -369,7 +365,7 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ diff --git a/lapack-netlib/SRC/dlauu2.f b/lapack-netlib/SRC/dlauu2.f index a026d96de1..b62eaad835 100644 --- a/lapack-netlib/SRC/dlauu2.f +++ b/lapack-netlib/SRC/dlauu2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DLAUU2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -95,10 +93,11 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup doubleOTHERauxiliary +*> \ingroup lauu2 * * ===================================================================== SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -164,8 +163,10 @@ SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO ) DO 10 I = 1, N AII = A( I, I ) IF( I.LT.N ) THEN - A( I, I ) = DDOT( N-I+1, A( I, I ), LDA, A( I, I ), LDA ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), + A( I, I ) = DDOT( N-I+1, A( I, I ), LDA, A( I, I ), + $ LDA ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, + $ I+1 ), $ LDA, A( I, I+1 ), LDA, AII, A( 1, I ), 1 ) ELSE CALL DSCAL( I, AII, A( 1, I ), 1 ) @@ -180,7 +181,8 @@ SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO ) AII = A( I, I ) IF( I.LT.N ) THEN A( I, I ) = DDOT( N-I+1, A( I, I ), 1, A( I, I ), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, + CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), + $ LDA, $ A( I+1, I ), 1, AII, A( I, 1 ), LDA ) ELSE CALL DSCAL( I, AII, A( I, 1 ), LDA ) diff --git a/lapack-netlib/SRC/dlauum.c b/lapack-netlib/SRC/dlauum.c index 34af5ced12..1721726a2b 100644 --- a/lapack-netlib/SRC/dlauum.c +++ b/lapack-netlib/SRC/dlauum.c @@ -228,21 +228,15 @@ typedef struct Namelist Namelist; -/* Table of constant values */ -static integer c__1 = 1; -static integer c_n1 = -1; -static doublereal c_b15 = 1.; - -/* > \brief \b DLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (b -locked algorithm). */ +/* > \brief \b DLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (d +river algorithm). */ /* =========== DOCUMENTATION =========== */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download DLAUUM + dependencies */ /* > */ @@ -253,7 +247,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -275,11 +268,13 @@ f"> */ /* > the array A. */ /* > */ /* > If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ -/* > overwriting the factor U in A. */ +/* > overwriting the factor U in A, and the strictly lower triangular part */ +/* > of A is not referenced. */ /* > If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ -/* > overwriting the factor L in A. */ +/* > overwriting the factor L in A, and the strictly upper triangular part */ +/* > of A is not referenced. */ /* > */ -/* > This is the blocked form of the algorithm, calling Level 3 BLAS. */ +/* > This is the driver that dispatches to either blocked or recursive */ /* > \endverbatim */ /* Arguments: */ @@ -305,9 +300,11 @@ f"> */ /* > A is DOUBLE PRECISION array, dimension (LDA,N) */ /* > On entry, the triangular factor U or L. */ /* > On exit, if UPLO = 'U', the upper triangle of A is */ -/* > overwritten with the upper triangle of the product U * U**T; */ -/* > if UPLO = 'L', the lower triangle of A is overwritten with */ -/* > the lower triangle of the product L**T * L. */ +/* > overwritten with the upper triangle of the product U * U**T, */ +/* > and the strictly lower triangular part of A is not referenced. */ +/* > If UPLO = 'L', the lower triangle of A is overwritten with */ +/* > the lower triangle of the product L**T * L, and the strictly upper */ +/* > triangular part of A is not referenced. */ /* > \endverbatim */ /* > */ /* > \param[in] LDA */ @@ -331,41 +328,25 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup doubleOTHERauxiliary */ +/* > \ingroup lauum */ /* ===================================================================== */ /* Subroutine */ void dlauum_(char *uplo, integer *n, doublereal *a, integer * lda, 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; /* Local variables */ - integer i__; - extern /* Subroutine */ void dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); - extern /* Subroutine */ void dtrmm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *); logical upper; - extern /* Subroutine */ void dsyrk_(char *, char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, doublereal *, - integer *), dlauu2_(char *, integer *, - doublereal *, integer *, integer *); - integer ib, nb; - extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), dlauum_recursive( + char *, integer *, doublereal *, integer *, integer *); -/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK auxiliary routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -375,7 +356,7 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ @@ -400,81 +381,14 @@ f"> */ return; } -/* Determine the block size for this environment. */ - - nb = ilaenv_(&c__1, "DLAUUM", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( - ftnlen)1); - - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code */ - - dlauu2_(uplo, n, &a[a_offset], lda, info); - } else { - -/* Use blocked code */ - - if (upper) { - -/* Compute the product U * U**T. */ - - i__1 = *n; - i__2 = nb; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__3 = nb, i__4 = *n - i__ + 1; - ib = f2cmin(i__3,i__4); - i__3 = i__ - 1; - dtrmm_("Right", "Upper", "Transpose", "Non-unit", &i__3, &ib, - &c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ * a_dim1 - + 1], lda) - ; - dlauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); - if (i__ + ib <= *n) { - i__3 = i__ - 1; - i__4 = *n - i__ - ib + 1; - dgemm_("No transpose", "Transpose", &i__3, &ib, &i__4, & - c_b15, &a[(i__ + ib) * a_dim1 + 1], lda, &a[i__ + - (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ * - a_dim1 + 1], lda); - i__3 = *n - i__ - ib + 1; - dsyrk_("Upper", "No transpose", &ib, &i__3, &c_b15, &a[ - i__ + (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ + - i__ * a_dim1], lda); - } -/* L10: */ - } - } else { - -/* Compute the product L**T * L. */ - - i__2 = *n; - i__1 = nb; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { -/* Computing MIN */ - i__3 = nb, i__4 = *n - i__ + 1; - ib = f2cmin(i__3,i__4); - i__3 = i__ - 1; - dtrmm_("Left", "Lower", "Transpose", "Non-unit", &ib, &i__3, & - c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ + a_dim1], - lda); - dlauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); - if (i__ + ib <= *n) { - i__3 = i__ - 1; - i__4 = *n - i__ - ib + 1; - dgemm_("Transpose", "No transpose", &ib, &i__3, &i__4, & - c_b15, &a[i__ + ib + i__ * a_dim1], lda, &a[i__ + - ib + a_dim1], lda, &c_b15, &a[i__ + a_dim1], lda); - i__3 = *n - i__ - ib + 1; - dsyrk_("Lower", "Transpose", &ib, &i__3, &c_b15, &a[i__ + - ib + i__ * a_dim1], lda, &c_b15, &a[i__ + i__ * - a_dim1], lda); - } -/* L20: */ - } - } - } +/* Here we dispatch to whatever is more efficient in a particular environment */ +/* We are defaulting to recursive, but if you want to use the blocked variant */ +/* Comment out the line starting with `CALL DLAUUM_...` */ +/* and uncomment the line starting with `CALL DLAUUM_BLOCKED...` */ + dlauum_recursive_(uplo, n, &a[a_offset], lda, info); + //dlauum_blocked(uplo, n, &a[a_offset], lda, info); +/* CALL DLAUUM_BLOCKED(UPLO, N, A, LDA, INFO) */ return; /* End of DLAUUM */ diff --git a/lapack-netlib/SRC/dlauum.f b/lapack-netlib/SRC/dlauum.f index b832eaa869..2137b80bfc 100644 --- a/lapack-netlib/SRC/dlauum.f +++ b/lapack-netlib/SRC/dlauum.f @@ -1,11 +1,10 @@ -*> \brief \b DLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm). +*> \brief \b DLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (driver algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DLAUUM + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -39,11 +37,13 @@ *> the array A. *> *> If UPLO = 'U' or 'u' then the upper triangle of the result is stored, -*> overwriting the factor U in A. +*> overwriting the factor U in A, and the strictly lower triangular part +*> of A is not referenced. *> If UPLO = 'L' or 'l' then the lower triangle of the result is stored, -*> overwriting the factor L in A. +*> overwriting the factor L in A, and the strictly upper triangular part +*> of A is not referenced. *> -*> This is the blocked form of the algorithm, calling Level 3 BLAS. +*> This is the driver that dispatches to either blocked or recursive *> \endverbatim * * Arguments: @@ -69,9 +69,11 @@ *> A is DOUBLE PRECISION array, dimension (LDA,N) *> On entry, the triangular factor U or L. *> On exit, if UPLO = 'U', the upper triangle of A is -*> overwritten with the upper triangle of the product U * U**T; -*> if UPLO = 'L', the lower triangle of A is overwritten with -*> the lower triangle of the product L**T * L. +*> overwritten with the upper triangle of the product U * U**T, +*> and the strictly lower triangular part of A is not referenced. +*> If UPLO = 'L', the lower triangle of A is overwritten with +*> the lower triangle of the product L**T * L, and the strictly upper +*> triangular part of A is not referenced. *> \endverbatim *> *> \param[in] LDA @@ -95,10 +97,11 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup doubleOTHERauxiliary +*> \ingroup lauum * * ===================================================================== SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -114,24 +117,19 @@ SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO ) * * ===================================================================== * -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. * .. Local Scalars .. LOGICAL UPPER - INTEGER I, IB, NB * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV + EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL DGEMM, DLAUU2, DSYRK, DTRMM, XERBLA + EXTERNAL XERBLA, DLAUUM_RECURSIVE, + $ DLAUUM_BLOCKED * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN + INTRINSIC MAX * .. * .. Executable Statements .. * @@ -156,58 +154,13 @@ SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO ) IF( N.EQ.0 ) $ RETURN * -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DLAUUM', UPLO, N, -1, -1, -1 ) -* - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL DLAUU2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute the product U * U**T. -* - DO 10 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', - $ I-1, IB, ONE, A( I, I ), LDA, A( 1, I ), - $ LDA ) - CALL DLAUU2( 'Upper', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL DGEMM( 'No transpose', 'Transpose', I-1, IB, - $ N-I-IB+1, ONE, A( 1, I+IB ), LDA, - $ A( I, I+IB ), LDA, ONE, A( 1, I ), LDA ) - CALL DSYRK( 'Upper', 'No transpose', IB, N-I-IB+1, - $ ONE, A( I, I+IB ), LDA, ONE, A( I, I ), - $ LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the product L**T * L. -* - DO 20 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL DTRMM( 'Left', 'Lower', 'Transpose', 'Non-unit', IB, - $ I-1, ONE, A( I, I ), LDA, A( I, 1 ), LDA ) - CALL DLAUU2( 'Lower', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No transpose', IB, I-1, - $ N-I-IB+1, ONE, A( I+IB, I ), LDA, - $ A( I+IB, 1 ), LDA, ONE, A( I, 1 ), LDA ) - CALL DSYRK( 'Lower', 'Transpose', IB, N-I-IB+1, ONE, - $ A( I+IB, I ), LDA, ONE, A( I, I ), LDA ) - END IF - 20 CONTINUE - END IF - END IF +* Here we dispatch to whatever is more efficient in a particular environment +* We are defaulting to recursive, but if you want to use the blocked variant +* Comment out the line starting with `CALL DLAUUM_RECURSIVE...` +* and uncomment the line starting with `CALL DLAUUM_BLOCKED...` * + CALL DLAUUM_RECURSIVE(UPLO, N, A, LDA, INFO) +* CALL DLAUUM_BLOCKED(UPLO, N, A, LDA, INFO) RETURN * * End of DLAUUM diff --git a/lapack-netlib/SRC/dlauum_blocked.c b/lapack-netlib/SRC/dlauum_blocked.c new file mode 100644 index 0000000000..16dfd36114 --- /dev/null +++ b/lapack-netlib/SRC/dlauum_blocked.c @@ -0,0 +1,471 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#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_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)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#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 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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#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)} + +/* -- translated by f2c (version 20000121). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + + + + + +/* Table of constant values */ + +static integer c__1 = 1; +static integer c_n1 = -1; +static doublereal c_b15 = 1.; + +/* > \brief \b DLAUUM_BLOCKED computes the product UUH or LHL, where U and L are upper or lower triangular mat +rices (blocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAUUM_BLOCKED( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* DOUBLE PRECISION A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAUUM_BLOCKED computes the product U * U**T or L**T * L, where the triangular */ +/* > factor U or L is stored in the upper or lower triangular part of */ +/* > the array A. */ +/* > */ +/* > If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ +/* > overwriting the factor U in A, and the strictly lower triangular part */ +/* > of A is not referenced. */ +/* > If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ +/* > overwriting the factor L in A, and the strictly upper triangular part */ +/* > of A is not referenced. */ +/* > */ +/* > This is the blocked form of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the triangular factor stored in the array A */ +/* > is upper or lower triangular: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the triangular factor U or L. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the triangular factor U or L. */ +/* > On exit, if UPLO = 'U', the upper triangle of A is */ +/* > overwritten with the upper triangle of the product U * U**T, */ +/* > and the strictly lower triangular part of A is not referenced. */ +/* > If UPLO = 'L', the lower triangle of A is overwritten with */ +/* > the lower triangle of the product L**T * L, and the strictly */ +/* > upper triangular part of A is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup lauum */ + +/* ===================================================================== */ +/* Subroutine */ void dlauum_blocked_(char *uplo, integer *n, doublereal *a, + integer *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, ib, nb; + extern /* Subroutine */ void dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ void dtrmm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + logical upper; + extern /* Subroutine */ void dsyrk_(char *, char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + integer *), dlauu2_(char *, integer *, + doublereal *, integer *, integer *), xerbla_(char *, + integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + +/* -- LAPACK auxiliary routine -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAUUM_BLOCKED", &i__1, (ftnlen)14); + return; + } + +/* Quick return if possible */ + + if (*n == 0) { + return; + } + +/* Determine the block size for this environment. */ + + nb = ilaenv_(&c__1, "DLAUUM_BLOCKED", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)14, (ftnlen)1); + + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + dlauu2_(uplo, n, &a[a_offset], lda, info); + } else { + +/* Use blocked code */ + + if (upper) { + +/* Compute the product U * U**T. */ + + i__1 = *n; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - i__ + 1; + ib = f2cmin(i__3,i__4); + i__3 = i__ - 1; + dtrmm_("Right", "Upper", "Transpose", "Non-unit", &i__3, &ib, + &c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ * a_dim1 + + 1], lda) + ; + dlauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); + if (i__ + ib <= *n) { + i__3 = i__ - 1; + i__4 = *n - i__ - ib + 1; + dgemm_("No transpose", "Transpose", &i__3, &ib, &i__4, & + c_b15, &a[(i__ + ib) * a_dim1 + 1], lda, &a[i__ + + (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ * + a_dim1 + 1], lda); + i__3 = *n - i__ - ib + 1; + dsyrk_("Upper", "No transpose", &ib, &i__3, &c_b15, &a[ + i__ + (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ + + i__ * a_dim1], lda); + } +/* L10: */ + } + } else { + +/* Compute the product L**T * L. */ + + i__2 = *n; + i__1 = nb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - i__ + 1; + ib = f2cmin(i__3,i__4); + i__3 = i__ - 1; + dtrmm_("Left", "Lower", "Transpose", "Non-unit", &ib, &i__3, & + c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ + a_dim1], + lda); + dlauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); + if (i__ + ib <= *n) { + i__3 = i__ - 1; + i__4 = *n - i__ - ib + 1; + dgemm_("Transpose", "No transpose", &ib, &i__3, &i__4, & + c_b15, &a[i__ + ib + i__ * a_dim1], lda, &a[i__ + + ib + a_dim1], lda, &c_b15, &a[i__ + a_dim1], lda); + i__3 = *n - i__ - ib + 1; + dsyrk_("Lower", "Transpose", &ib, &i__3, &c_b15, &a[i__ + + ib + i__ * a_dim1], lda, &c_b15, &a[i__ + i__ * + a_dim1], lda); + } +/* L20: */ + } + } + } + + return; + +/* End of DLAUUM_BLOCKED */ + +} /* dlauum_blocked__ */ + diff --git a/lapack-netlib/SRC/dlauum_blocked.f b/lapack-netlib/SRC/dlauum_blocked.f new file mode 100644 index 0000000000..796e730529 --- /dev/null +++ b/lapack-netlib/SRC/dlauum_blocked.f @@ -0,0 +1,212 @@ +*> \brief \b DLAUUM_BLOCKED computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DLAUUM_BLOCKED( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAUUM_BLOCKED computes the product U * U**T or L**T * L, where the triangular +*> factor U or L is stored in the upper or lower triangular part of +*> the array A. +*> +*> If UPLO = 'U' or 'u' then the upper triangle of the result is stored, +*> overwriting the factor U in A, and the strictly lower triangular part +*> of A is not referenced. +*> If UPLO = 'L' or 'l' then the lower triangle of the result is stored, +*> overwriting the factor L in A, and the strictly upper triangular part +*> of A is not referenced. +*> +*> This is the blocked form of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the triangular factor stored in the array A +*> is upper or lower triangular: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the triangular factor U or L. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the triangular factor U or L. +*> On exit, if UPLO = 'U', the upper triangle of A is +*> overwritten with the upper triangle of the product U * U**T, +*> and the strictly lower triangular part of A is not referenced. +*> If UPLO = 'L', the lower triangle of A is overwritten with +*> the lower triangle of the product L**T * L, and the strictly +*> upper triangular part of A is not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lauum +* +* ===================================================================== + SUBROUTINE DLAUUM_BLOCKED( UPLO, N, A, LDA, INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IB, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLAUU2, DTRMM, DGEMM, DSYRK +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAUUM_BLOCKED', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'DLAUUM_BLOCKED', UPLO, N, -1, -1, -1 ) +* + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL DLAUU2( UPLO, N, A, LDA, INFO ) + ELSE +* +* Use blocked code +* + IF( UPPER ) THEN +* +* Compute the product U * U**T. +* + DO 10 I = 1, N, NB + IB = MIN( NB, N-I+1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', + $ I-1, IB, ONE, A( I, I ), LDA, A( 1, I ), + $ LDA ) + CALL DLAUU2( 'Upper', IB, A( I, I ), LDA, INFO ) + IF( I+IB.LE.N ) THEN + CALL DGEMM( 'No transpose', 'Transpose', I-1, IB, + $ N-I-IB+1, ONE, A( 1, I+IB ), LDA, + $ A( I, I+IB ), LDA, ONE, A( 1, I ), LDA ) + CALL DSYRK( 'Upper', 'No transpose', IB, N-I-IB+1, + $ ONE, A( I, I+IB ), LDA, ONE, A( I, I ), + $ LDA ) + END IF + 10 CONTINUE + ELSE +* +* Compute the product L**T * L. +* + DO 20 I = 1, N, NB + IB = MIN( NB, N-I+1 ) + CALL DTRMM( 'Left', 'Lower', 'Transpose', 'Non-unit', + $ IB, + $ I-1, ONE, A( I, I ), LDA, A( I, 1 ), LDA ) + CALL DLAUU2( 'Lower', IB, A( I, I ), LDA, INFO ) + IF( I+IB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No transpose', IB, I-1, + $ N-I-IB+1, ONE, A( I+IB, I ), LDA, + $ A( I+IB, 1 ), LDA, ONE, A( I, 1 ), LDA ) + CALL DSYRK( 'Lower', 'Transpose', IB, N-I-IB+1, + $ ONE, + $ A( I+IB, I ), LDA, ONE, A( I, I ), LDA ) + END IF + 20 CONTINUE + END IF + END IF +* + RETURN +* +* End of DLAUUM_BLOCKED +* + END diff --git a/lapack-netlib/SRC/dlauum_recursive.c b/lapack-netlib/SRC/dlauum_recursive.c new file mode 100644 index 0000000000..7243b3b1be --- /dev/null +++ b/lapack-netlib/SRC/dlauum_recursive.c @@ -0,0 +1,524 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#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_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)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#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 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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#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)} + +/* -- translated by f2c (version 20000121). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + + + + + + +/* Table of constant values */ + +static integer c__3 = 3; +static integer c_n1 = -1; +static doublereal c_b12 = 1.; + +/* > \brief \b DLAUUM_ computes the product UUH or LHL, where U and L are upper or lower triangular matrices ( +recursive algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAUUM_( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* DOUBLE PRECISION A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAUUM_ computes the product U * U**T or L**T * L, where the triangular */ +/* > factor U or L is stored in the upper or lower triangular part of */ +/* > the array A. */ +/* > */ +/* > If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ +/* > overwriting the factor U in A, and the strictly lower triangular part */ +/* > of A is not referenced. */ +/* > If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ +/* > overwriting the factor L in A, and the strictly upper triangular part */ +/* > of A is not referenced. */ +/* > */ +/* > This is the recursive version of the algorithm */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the triangular factor stored in the array A */ +/* > is upper or lower triangular: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the triangular factor U or L. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the triangular factor U or L. */ +/* > On exit, if UPLO = 'U', the upper triangle of A is */ +/* > overwritten with the upper triangle of the product U * U**T, */ +/* > and the strictly lower triangular part of A is not referenced. */ +/* > If UPLO = 'L', the lower triangle of A is overwritten with */ +/* > the lower triangle of the product L**T * L, and the */ +/* > strictly upper triangular part of A is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup lauum */ + +/* ===================================================================== */ +/* Subroutine */ void dlauum_recursive_(char *uplo, integer *n, doublereal *a, integer + *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + integer k, nx; + extern logical lsame_(char *, char *); + extern /* Subroutine */ void dtrmm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + logical upper; + extern /* Subroutine */ void dsyrk_(char *, char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + integer *), dlauu2_(char *, integer *, + doublereal *, integer *, integer *), xerbla_(char *, + integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + +/* -- LAPACK auxiliary routine -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAUUM_RECURSIVE", &i__1, (ftnlen)16); + return; + } + +/* Early termination criteria */ + + if (*n == 0) { + return; + } + +/* Base Case */ + + if (*n == 1) { + a[a_dim1 + 1] *= a[a_dim1 + 1]; + return; + } + +/* Determine crossover point for when to bail to level2 */ + + nx = ilaenv_(&c__3, "DLAUUM_RECURSIVE", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)16, ( + ftnlen)1); + if (*n < nx) { + dlauu2_(uplo, n, &a[a_offset], lda, info); + return; + } + +/* Beginning of executable statements for the recursive case */ + + k = *n / 2; + if (upper) { + +/* We are computing A = ut(U*U**T). */ + +/* Break apart U as follows */ +/* |-----------------| */ +/* U = | U_{11} U_{12} | */ +/* | 0 U_{22} | */ +/* |-----------------| */ + +/* Where */ +/* U_{11}\in\R^{k\times k} U_{12}\in\R^{ k\times n-k} */ +/* U_{22}\in\R^{n-k\times n-k} */ + +/* and U_{11},U_{22} are upper triangular and U_{12} is rectangular */ + +/* This gives us our operations as */ +/* |--------------------| |------------------------| */ +/* ut(U * U**T) = | U_{11} U_{12} | | U_{11}**T 0 | */ +/* | 0 U_{22} | | U_{12}**T U_{22}**T | */ +/* |--------------------| |------------------------| */ + +/* Thus we get */ + +/* U_{11} = U_{11}U_{11}**T + U_{12}U_{12}**T */ +/* U_{12} = U_{12}U_{22}**T */ + +/* U_{22} = U_{22}U_{22}**T */ + +/* We break these operations apart as follows */ + +/* U_{11} = U_{11}U_{11}**T (This subroutine) */ +/* U_{11} = U_{12}U_{12}**T + U_{11} (SYRK) */ + +/* U_{12} = U_{12}U_{22}**T (TRMM) */ + +/* U_{22} = U_{22}U_{22}**T (This subroutine) */ + + +/* Compute U_{11} */ + + dlauum_recursive_(uplo, &k, &a[a_offset], lda, info); + i__1 = *n - k; + dsyrk_("Upper", "No Transpose", &k, &i__1, &c_b12, &a[(k + 1) * + a_dim1 + 1], lda, &c_b12, &a[a_offset], lda); + +/* Compute U_{12} */ + + i__1 = *n - k; + dtrmm_("Right", "Upper", "Transpose", "Non-unit", &k, &i__1, &c_b12, & + a[k + 1 + (k + 1) * a_dim1], lda, &a[(k + 1) * a_dim1 + 1], + lda); + +/* Compute U_{22} */ + + i__1 = *n - k; + dlauum_recursive_(uplo, &i__1, &a[k + 1 + (k + 1) * a_dim1], lda, info); + } else { + +/* We are computing A = lt(L**T*L). */ + +/* Break apart L as follows */ +/* |-----------------| */ +/* L = | L_{11} 0 | */ +/* | L_{21} L_{22} | */ +/* |-----------------| */ + +/* Where */ +/* L_{11}\in\R^{ k\times k} */ +/* L_{21}\in\R^{n-k\times k} l_{22}\in\R^{n-k\times n-k} */ + +/* and L_{11},L_{22} are lower triangular and L_{21} is rectangular */ + +/* This gives us our operations as */ +/* |--------------------------| |-----------------| */ +/* lt(L**T * L) = | L_{11}**T L_{21}**T | | L_{11} 0 | */ +/* | 0 L_{22}**T | | L_{21} L_{22} | */ +/* |--------------------------| |-----------------| */ + +/* Thus we get */ + +/* L_{11} = L_{11}**T L_{11} + L_{21}**T L_{21} */ +/* L_{21} = L_{22}**T L_{21} */ + +/* L_{22} = L_{22}**T L_{22} */ + +/* We break these operations apart as follows */ + +/* L_{11} = L_{11}**T L_{11} (This subroutine) */ +/* L_{11} = L_{21}**T L_{21} + L_{11} (SYRK) */ + +/* L_{21} = L_{22}**T L_{21} (TRMM) */ + +/* L_{22} = L_{22}**T L_{22} (This subroutine) */ + + +/* Compute L_{11} */ + + dlauum_recursive_(uplo, &k, &a[a_offset], lda, info); + i__1 = *n - k; + dsyrk_("Lower", "Transpose", &k, &i__1, &c_b12, &a[k + 1 + a_dim1], + lda, &c_b12, &a[a_offset], lda); + +/* Compute L_{21} */ + + i__1 = *n - k; + dtrmm_("Left", "Lower", "Transpose", "Non-Unit", &i__1, &k, &c_b12, & + a[k + 1 + (k + 1) * a_dim1], lda, &a[k + 1 + a_dim1], lda); + +/* Compute L_{22} */ + + i__1 = *n - k; + dlauum_recursive_(uplo, &i__1, &a[k + 1 + (k + 1) * a_dim1], lda, info); + } + return; +} /* dlauum___ */ + diff --git a/lapack-netlib/SRC/dlauum_recursive.f b/lapack-netlib/SRC/dlauum_recursive.f new file mode 100644 index 0000000000..18a58ee074 --- /dev/null +++ b/lapack-netlib/SRC/dlauum_recursive.f @@ -0,0 +1,277 @@ +*> \brief \b DLAUUM_RECURSIVE computes the product UUH or LHL, where U and L are upper or lower triangular matrices (recursive algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DLAUUM_RECURSIVE( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAUUM_RECURSIVE computes the product U * U**T or L**T * L, where the triangular +*> factor U or L is stored in the upper or lower triangular part of +*> the array A. +*> +*> If UPLO = 'U' or 'u' then the upper triangle of the result is stored, +*> overwriting the factor U in A, and the strictly lower triangular part +*> of A is not referenced. +*> If UPLO = 'L' or 'l' then the lower triangle of the result is stored, +*> overwriting the factor L in A, and the strictly upper triangular part +*> of A is not referenced. +*> +*> This is the recursive version of the algorithm +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the triangular factor stored in the array A +*> is upper or lower triangular: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the triangular factor U or L. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the triangular factor U or L. +*> On exit, if UPLO = 'U', the upper triangle of A is +*> overwritten with the upper triangle of the product U * U**T, +*> and the strictly lower triangular part of A is not referenced. +*> If UPLO = 'L', the lower triangle of A is overwritten with +*> the lower triangle of the product L**T * L, and the +*> strictly upper triangular part of A is not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lauum +* +* ===================================================================== + RECURSIVE SUBROUTINE DLAUUM_RECURSIVE( UPLO, N, A, LDA, INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, NX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLAUU2, DSYRK, DTRMM +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAUUM_RECURSIVE', -INFO ) + RETURN + END IF +* +* Early termination criteria +* + IF( N.EQ.0 ) THEN + RETURN + END IF +* +* Base Case +* + IF( N.EQ.1 ) THEN + A(1,1) = A(1,1) * A(1,1) + RETURN + END IF +* +* Determine crossover point for when to bail to level2 +* + NX = ILAENV(3, "DLAUUM_RECURSIVE", UPLO, N, -1, -1, -1) + IF( N.LT.NX ) THEN + CALL DLAUU2(UPLO, N, A, LDA, INFO) + RETURN + END IF +* +* Beginning of executable statements for the recursive case +* + K = N/2 + IF( UPPER ) THEN +* +* We are computing A = ut(U*U**T). +* +* Break apart U as follows +* |-----------------| +* U = | U_{11} U_{12} | +* | 0 U_{22} | +* |-----------------| +* +* Where +* U_{11}\in\R^{k\times k} U_{12}\in\R^{ k\times n-k} +* U_{22}\in\R^{n-k\times n-k} +* +* and U_{11},U_{22} are upper triangular and U_{12} is rectangular +* +* This gives us our operations as +* |--------------------| |------------------------| +* ut(U * U**T) = | U_{11} U_{12} | | U_{11}**T 0 | +* | 0 U_{22} | | U_{12}**T U_{22}**T | +* |--------------------| |------------------------| +* +* Thus we get +* +* U_{11} = U_{11}U_{11}**T + U_{12}U_{12}**T +* U_{12} = U_{12}U_{22}**T +* +* U_{22} = U_{22}U_{22}**T +* +* We break these operations apart as follows +* +* U_{11} = U_{11}U_{11}**T (This subroutine) +* U_{11} = U_{12}U_{12}**T + U_{11} (SYRK) +* +* U_{12} = U_{12}U_{22}**T (TRMM) +* +* U_{22} = U_{22}U_{22}**T (This subroutine) +* +* +* Compute U_{11} +* + CALL DLAUUM_RECURSIVE(UPLO, K, A, LDA, INFO) + CALL DSYRK('Upper', 'No Transpose', K, N-K, + $ ONE, A(1,K+1), LDA, ONE, A, LDA) +* +* Compute U_{12} +* + CALL DTRMM('Right', 'Upper', 'Transpose', 'Non-unit', + $ K, N-K, ONE, A(K+1,K+1), LDA, A(1,K+1), LDA) +* +* Compute U_{22} +* + CALL DLAUUM_RECURSIVE(UPLO, N-K, A(K+1,K+1), LDA, INFO) + ELSE +* +* We are computing A = lt(L**T*L). +* +* Break apart L as follows +* |-----------------| +* L = | L_{11} 0 | +* | L_{21} L_{22} | +* |-----------------| +* +* Where +* L_{11}\in\R^{ k\times k} +* L_{21}\in\R^{n-k\times k} l_{22}\in\R^{n-k\times n-k} +* +* and L_{11},L_{22} are lower triangular and L_{21} is rectangular +* +* This gives us our operations as +* |--------------------------| |-----------------| +* lt(L**T * L) = | L_{11}**T L_{21}**T | | L_{11} 0 | +* | 0 L_{22}**T | | L_{21} L_{22} | +* |--------------------------| |-----------------| +* +* Thus we get +* +* L_{11} = L_{11}**T L_{11} + L_{21}**T L_{21} +* L_{21} = L_{22}**T L_{21} +* +* L_{22} = L_{22}**T L_{22} +* +* We break these operations apart as follows +* +* L_{11} = L_{11}**T L_{11} (This subroutine) +* L_{11} = L_{21}**T L_{21} + L_{11} (SYRK) +* +* L_{21} = L_{22}**T L_{21} (TRMM) +* +* L_{22} = L_{22}**T L_{22} (This subroutine) +* +* +* Compute L_{11} +* + CALL DLAUUM_RECURSIVE(UPLO, K, A, LDA, INFO) + CALL DSYRK('Lower', 'Transpose', K, N-K, + $ ONE, A(K+1,1), LDA, ONE, A, LDA) +* +* Compute L_{21} +* + CALL DTRMM('Left', 'Lower', 'Transpose', 'Non-Unit', + $ N-K, K, ONE, A(K+1,K+1), LDA, A(K+1,1), LDA) +* +* Compute L_{22} +* + CALL DLAUUM_RECURSIVE(UPLO, N-K, A(K+1,K+1), LDA, INFO) + END IF + END SUBROUTINE diff --git a/lapack-netlib/SRC/ilaenv.c b/lapack-netlib/SRC/ilaenv.c index 81552492cd..f15bdf3087 100644 --- a/lapack-netlib/SRC/ilaenv.c +++ b/lapack-netlib/SRC/ilaenv.c @@ -188,8 +188,8 @@ typedef struct Namelist Namelist; /* Table of constant values */ static integer c__1 = 1; -static real c_b179 = 0.f; -static real c_b180 = 1.f; +static real c_b185 = 0.f; +static real c_b186 = 1.f; static integer c__0 = 0; /* > \brief \b ILAENV */ @@ -199,7 +199,6 @@ static integer c__0 = 0; /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ILAENV + dependencies */ /* > */ @@ -210,7 +209,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -363,14 +361,13 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, /* Local variables */ logical twostage; integer i__; + char c1[1], c2[2], c3[3], c4[2]; + integer ic, nb, iz, nx; logical cname; integer nbmin; logical sname; - char c1[1], c2[2], c3[3], c4[2]; - integer ic, nb; extern integer ieeeck_(integer *, real *, real *); - integer iz, nx; - char subnam[17]; + char subnam[16]; extern integer iparmq_(integer *, char *, char *, integer *, integer *, integer *, integer *); @@ -413,7 +410,7 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, /* Convert NAME to upper case if the first character is lower case. */ ret_val = 1; - //s_copy(subnam, name__, (ftnlen)16, name_len); +// s_copy(subnam, name__, (ftnlen)16, name_len); strncpy(subnam,name__,16); subnam[16]='\0'; ic = *(unsigned char *)subnam; @@ -503,6 +500,16 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, } else { nb = 32; } + } else if (s_cmp(subnam + 1, "TZRZF", (ftnlen)5, (ftnlen)5) == 0) { + if (sname) { + nb = 64; + } else { + nb = 32; + } + } else if (s_cmp(subnam + 1, "ORMRZ", (ftnlen)5, (ftnlen)5) == 0) { + nb = 64; + } else if (s_cmp(subnam + 1, "UNMRZ", (ftnlen)5, (ftnlen)5) == 0) { + nb = 32; } else if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) { if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) { if (sname) { @@ -934,6 +941,16 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, if (s_cmp(c3, "HD3", (ftnlen)3, (ftnlen)3) == 0) { nx = 128; } + } else if (s_cmp(c2, "LA", (ftnlen)2, (ftnlen)2) == 0) { + if (s_cmp(c3, "RFT", (ftnlen)3, (ftnlen)3) == 0) { + nx = 64; + } else if (s_cmp(c3, "UUM", (ftnlen)3, (ftnlen)3) == 0) { + +/* Note that this matches on *lauum_recursive, which is the */ +/* only place we currently use this */ + + nx = 64; + } } ret_val = nx; return ret_val; @@ -989,7 +1006,7 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, /* ILAENV = 0 */ ret_val = 1; if (ret_val == 1) { - ret_val = ieeeck_(&c__1, &c_b179, &c_b180); + ret_val = ieeeck_(&c__1, &c_b185, &c_b186); } return ret_val; @@ -1000,7 +1017,7 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, /* ILAENV = 0 */ ret_val = 1; if (ret_val == 1) { - ret_val = ieeeck_(&c__0, &c_b179, &c_b180); + ret_val = ieeeck_(&c__0, &c_b185, &c_b186); } return ret_val; diff --git a/lapack-netlib/SRC/ilaenv.f b/lapack-netlib/SRC/ilaenv.f index f985e05b84..2622d44cc1 100644 --- a/lapack-netlib/SRC/ilaenv.f +++ b/lapack-netlib/SRC/ilaenv.f @@ -179,8 +179,8 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) INTRINSIC CHAR, ICHAR, INT, MIN, REAL * .. * .. External Functions .. - INTEGER IEEECK, IPARMQ, IPARAM2STAGE - EXTERNAL IEEECK, IPARMQ, IPARAM2STAGE + INTEGER IEEECK, IPARMQ + EXTERNAL IEEECK, IPARMQ * .. * .. Executable Statements .. * @@ -679,6 +679,12 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) ELSE IF( C2.EQ.'LA' ) THEN IF( C3.EQ.'RFT' ) THEN NX = 64 + ELSE IF( C3.EQ.'UUM' ) THEN +* +* Note that this matches on *lauum_recursive, which is the +* only place we currently use this +* + NX = 64 END IF END IF ILAENV = NX diff --git a/lapack-netlib/SRC/slauu2.c b/lapack-netlib/SRC/slauu2.c index 6bce7c2bf2..0f156cd29e 100644 --- a/lapack-netlib/SRC/slauu2.c +++ b/lapack-netlib/SRC/slauu2.c @@ -220,259 +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 SLAUU2 + dependencies */ /* > */ @@ -497,7 +243,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -575,9 +320,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup realOTHERauxiliary */ +/* > \ingroup lauu2 */ /* ===================================================================== */ /* Subroutine */ void slauu2_(char *uplo, integer *n, real *a, integer *lda, @@ -587,21 +330,20 @@ f"> */ integer a_dim1, a_offset, i__1, i__2, i__3; /* Local variables */ - extern real sdot_(integer *, real *, integer *, real *, integer *); integer i__; + real aii; + extern real sdot_(integer *, real *, integer *, real *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ void sscal_(integer *, real *, real *, integer *), sgemv_(char *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *); logical upper; extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - real aii; -/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK auxiliary routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -611,7 +353,7 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ diff --git a/lapack-netlib/SRC/slauu2.f b/lapack-netlib/SRC/slauu2.f index efe5e47efb..b328a2f5b2 100644 --- a/lapack-netlib/SRC/slauu2.f +++ b/lapack-netlib/SRC/slauu2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SLAUU2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -95,10 +93,11 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERauxiliary +*> \ingroup lauu2 * * ===================================================================== SUBROUTINE SLAUU2( UPLO, N, A, LDA, INFO ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -164,8 +163,10 @@ SUBROUTINE SLAUU2( UPLO, N, A, LDA, INFO ) DO 10 I = 1, N AII = A( I, I ) IF( I.LT.N ) THEN - A( I, I ) = SDOT( N-I+1, A( I, I ), LDA, A( I, I ), LDA ) - CALL SGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), + A( I, I ) = SDOT( N-I+1, A( I, I ), LDA, A( I, I ), + $ LDA ) + CALL SGEMV( 'No transpose', I-1, N-I, ONE, A( 1, + $ I+1 ), $ LDA, A( I, I+1 ), LDA, AII, A( 1, I ), 1 ) ELSE CALL SSCAL( I, AII, A( 1, I ), 1 ) @@ -180,7 +181,8 @@ SUBROUTINE SLAUU2( UPLO, N, A, LDA, INFO ) AII = A( I, I ) IF( I.LT.N ) THEN A( I, I ) = SDOT( N-I+1, A( I, I ), 1, A( I, I ), 1 ) - CALL SGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, + CALL SGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), + $ LDA, $ A( I+1, I ), 1, AII, A( I, 1 ), LDA ) ELSE CALL SSCAL( I, AII, A( I, 1 ), LDA ) diff --git a/lapack-netlib/SRC/slauum.c b/lapack-netlib/SRC/slauum.c index 5f14d1d821..bc585c100d 100644 --- a/lapack-netlib/SRC/slauum.c +++ b/lapack-netlib/SRC/slauum.c @@ -228,266 +228,16 @@ 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 \brief \b SLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (b -locked algorithm). */ +/* > \brief \b SLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (d +river algorithm). */ /* =========== DOCUMENTATION =========== */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download SLAUUM + dependencies */ /* > */ @@ -498,7 +248,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -520,11 +269,13 @@ f"> */ /* > the array A. */ /* > */ /* > If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ -/* > overwriting the factor U in A. */ +/* > overwriting the factor U in A, and the strictly lower triangular part */ +/* > of A is not referenced. */ /* > If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ -/* > overwriting the factor L in A. */ +/* > overwriting the factor L in A, and the strictly upper triangular part */ +/* > of A is not referenced. */ /* > */ -/* > This is the blocked form of the algorithm, calling Level 3 BLAS. */ +/* > This is the driver that dispatches to either blocked or recursive */ /* > \endverbatim */ /* Arguments: */ @@ -550,9 +301,11 @@ f"> */ /* > A is REAL array, dimension (LDA,N) */ /* > On entry, the triangular factor U or L. */ /* > On exit, if UPLO = 'U', the upper triangle of A is */ -/* > overwritten with the upper triangle of the product U * U**T; */ -/* > if UPLO = 'L', the lower triangle of A is overwritten with */ -/* > the lower triangle of the product L**T * L. */ +/* > overwritten with the upper triangle of the product U * U**T, */ +/* > and the strictly lower triangular part of A is not referenced. */ +/* > If UPLO = 'L', the lower triangle of A is overwritten with */ +/* > the lower triangle of the product L**T * L, and the strictly upper */ +/* > triangular part of A is not referenced. */ /* > \endverbatim */ /* > */ /* > \param[in] LDA */ @@ -576,42 +329,25 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup realOTHERauxiliary */ +/* > \ingroup lauum */ /* ===================================================================== */ /* Subroutine */ void slauum_(char *uplo, integer *n, real *a, integer *lda, 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; /* Local variables */ - integer i__; extern logical lsame_(char *, char *); - extern /* Subroutine */ void sgemm_(char *, char *, integer *, integer *, - integer *, real *, real *, integer *, real *, integer *, real *, - real *, integer *); logical upper; - extern /* Subroutine */ void strmm_(char *, char *, char *, char *, - integer *, integer *, real *, real *, integer *, real *, integer * - ), ssyrk_(char *, char *, integer - *, integer *, real *, real *, integer *, real *, real *, integer * - ); - integer ib; - extern /* Subroutine */ void slauu2_(char *, integer *, real *, integer *, - integer *); - integer nb; - extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - - -/* -- LAPACK auxiliary routine (version 3.7.0) -- */ + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), slauum_recursive_( + char *, integer *, real *, integer *, integer *); + + +/* -- LAPACK auxiliary routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -621,7 +357,7 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ @@ -646,81 +382,13 @@ f"> */ return; } -/* Determine the block size for this environment. */ - - nb = ilaenv_(&c__1, "SLAUUM", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( - ftnlen)1); - - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code */ - - slauu2_(uplo, n, &a[a_offset], lda, info); - } else { - -/* Use blocked code */ - - if (upper) { - -/* Compute the product U * U**T. */ - - i__1 = *n; - i__2 = nb; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__3 = nb, i__4 = *n - i__ + 1; - ib = f2cmin(i__3,i__4); - i__3 = i__ - 1; - strmm_("Right", "Upper", "Transpose", "Non-unit", &i__3, &ib, - &c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ * a_dim1 - + 1], lda) - ; - slauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); - if (i__ + ib <= *n) { - i__3 = i__ - 1; - i__4 = *n - i__ - ib + 1; - sgemm_("No transpose", "Transpose", &i__3, &ib, &i__4, & - c_b15, &a[(i__ + ib) * a_dim1 + 1], lda, &a[i__ + - (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ * - a_dim1 + 1], lda); - i__3 = *n - i__ - ib + 1; - ssyrk_("Upper", "No transpose", &ib, &i__3, &c_b15, &a[ - i__ + (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ + - i__ * a_dim1], lda); - } -/* L10: */ - } - } else { - -/* Compute the product L**T * L. */ - - i__2 = *n; - i__1 = nb; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { -/* Computing MIN */ - i__3 = nb, i__4 = *n - i__ + 1; - ib = f2cmin(i__3,i__4); - i__3 = i__ - 1; - strmm_("Left", "Lower", "Transpose", "Non-unit", &ib, &i__3, & - c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ + a_dim1], - lda); - slauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); - if (i__ + ib <= *n) { - i__3 = i__ - 1; - i__4 = *n - i__ - ib + 1; - sgemm_("Transpose", "No transpose", &ib, &i__3, &i__4, & - c_b15, &a[i__ + ib + i__ * a_dim1], lda, &a[i__ + - ib + a_dim1], lda, &c_b15, &a[i__ + a_dim1], lda); - i__3 = *n - i__ - ib + 1; - ssyrk_("Lower", "Transpose", &ib, &i__3, &c_b15, &a[i__ + - ib + i__ * a_dim1], lda, &c_b15, &a[i__ + i__ * - a_dim1], lda); - } -/* L20: */ - } - } - } +/* Here we dispatch to whatever is more efficient in a particular environment */ +/* We are defaulting to recursive, but if you want to use the blocked variant */ +/* Comment out the line starting with `CALL SLAUUM_...` */ +/* and uncomment the line starting with `CALL SLAUUM_BLOCKED...` */ + slauum_recursive_(uplo, n, &a[a_offset], lda, info); + //slauum_blocked_(uplo, n, &a[a_offset], lda, info); return; /* End of SLAUUM */ diff --git a/lapack-netlib/SRC/slauum.f b/lapack-netlib/SRC/slauum.f index a7b69432df..dbd9440483 100644 --- a/lapack-netlib/SRC/slauum.f +++ b/lapack-netlib/SRC/slauum.f @@ -1,11 +1,10 @@ -*> \brief \b SLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm). +*> \brief \b SLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (driver algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SLAUUM + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -39,11 +37,13 @@ *> the array A. *> *> If UPLO = 'U' or 'u' then the upper triangle of the result is stored, -*> overwriting the factor U in A. +*> overwriting the factor U in A, and the strictly lower triangular part +*> of A is not referenced. *> If UPLO = 'L' or 'l' then the lower triangle of the result is stored, -*> overwriting the factor L in A. +*> overwriting the factor L in A, and the strictly upper triangular part +*> of A is not referenced. *> -*> This is the blocked form of the algorithm, calling Level 3 BLAS. +*> This is the driver that dispatches to either blocked or recursive *> \endverbatim * * Arguments: @@ -69,9 +69,11 @@ *> A is REAL array, dimension (LDA,N) *> On entry, the triangular factor U or L. *> On exit, if UPLO = 'U', the upper triangle of A is -*> overwritten with the upper triangle of the product U * U**T; -*> if UPLO = 'L', the lower triangle of A is overwritten with -*> the lower triangle of the product L**T * L. +*> overwritten with the upper triangle of the product U * U**T, +*> and the strictly lower triangular part of A is not referenced. +*> If UPLO = 'L', the lower triangle of A is overwritten with +*> the lower triangle of the product L**T * L, and the strictly upper +*> triangular part of A is not referenced. *> \endverbatim *> *> \param[in] LDA @@ -95,10 +97,11 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERauxiliary +*> \ingroup lauum * * ===================================================================== SUBROUTINE SLAUUM( UPLO, N, A, LDA, INFO ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -114,24 +117,20 @@ SUBROUTINE SLAUUM( UPLO, N, A, LDA, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL UPPER - INTEGER I, IB, NB * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV + EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL SGEMM, SLAUU2, SSYRK, STRMM, XERBLA + EXTERNAL XERBLA, SLAUUM_RECURSIVE, + $ SLAUUM_BLOCKED * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN + INTRINSIC MAX * .. * .. Executable Statements .. * @@ -156,58 +155,13 @@ SUBROUTINE SLAUUM( UPLO, N, A, LDA, INFO ) IF( N.EQ.0 ) $ RETURN * -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'SLAUUM', UPLO, N, -1, -1, -1 ) -* - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL SLAUU2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute the product U * U**T. -* - DO 10 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL STRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', - $ I-1, IB, ONE, A( I, I ), LDA, A( 1, I ), - $ LDA ) - CALL SLAUU2( 'Upper', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL SGEMM( 'No transpose', 'Transpose', I-1, IB, - $ N-I-IB+1, ONE, A( 1, I+IB ), LDA, - $ A( I, I+IB ), LDA, ONE, A( 1, I ), LDA ) - CALL SSYRK( 'Upper', 'No transpose', IB, N-I-IB+1, - $ ONE, A( I, I+IB ), LDA, ONE, A( I, I ), - $ LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the product L**T * L. -* - DO 20 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL STRMM( 'Left', 'Lower', 'Transpose', 'Non-unit', IB, - $ I-1, ONE, A( I, I ), LDA, A( I, 1 ), LDA ) - CALL SLAUU2( 'Lower', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL SGEMM( 'Transpose', 'No transpose', IB, I-1, - $ N-I-IB+1, ONE, A( I+IB, I ), LDA, - $ A( I+IB, 1 ), LDA, ONE, A( I, 1 ), LDA ) - CALL SSYRK( 'Lower', 'Transpose', IB, N-I-IB+1, ONE, - $ A( I+IB, I ), LDA, ONE, A( I, I ), LDA ) - END IF - 20 CONTINUE - END IF - END IF +* Here we dispatch to whatever is more efficient in a particular environment +* We are defaulting to recursive, but if you want to use the blocked variant +* Comment out the line starting with `CALL SLAUUM_RECURSIVE...` +* and uncomment the line starting with `CALL SLAUUM_BLOCKED...` * + CALL SLAUUM_RECURSIVE(UPLO, N, A, LDA, INFO) +* CALL SLAUUM_BLOCKED(UPLO, N, A, LDA, INFO) RETURN * * End of SLAUUM diff --git a/lapack-netlib/SRC/slauum_blocked.c b/lapack-netlib/SRC/slauum_blocked.c new file mode 100644 index 0000000000..eb55182460 --- /dev/null +++ b/lapack-netlib/SRC/slauum_blocked.c @@ -0,0 +1,470 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#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_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)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#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 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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#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)} + +/* procedure parameter types for -A and -C++ */ + + +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + + +/* Table of constant values */ + +static integer c__1 = 1; +static integer c_n1 = -1; +static real c_b15 = 1.f; + +/* > \brief \b SLAUUM_BLOCKED computes the product UUH or LHL, where U and L are upper or lower triangular mat +rices (blocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAUUM_BLOCKED( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAUUM_BLOCKED computes the product U * U**T or L**T * L, where the triangular */ +/* > factor U or L is stored in the upper or lower triangular part of */ +/* > the array A. */ +/* > */ +/* > If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ +/* > overwriting the factor U in A, and the strictly lower triangular part */ +/* > of A is not referenced. */ +/* > If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ +/* > overwriting the factor L in A, and the strictly upper triangular part */ +/* > of A is not referenced. */ +/* > */ +/* > This is the blocked form of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the triangular factor stored in the array A */ +/* > is upper or lower triangular: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the triangular factor U or L. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the triangular factor U or L. */ +/* > On exit, if UPLO = 'U', the upper triangle of A is */ +/* > overwritten with the upper triangle of the product U * U**T, */ +/* > and the strictly lower triangular part of A is not referenced. */ +/* > If UPLO = 'L', the lower triangle of A is overwritten with */ +/* > the lower triangle of the product L**T * L, and the strictly */ +/* > upper triangular part of A is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup lauum */ + +/* ===================================================================== */ +/* Subroutine */ void slauum_blocked_(char *uplo, integer *n, real *a, + integer *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, ib, nb; + extern logical lsame_(char *, char *); + extern /* Subroutine */ void sgemm_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); + logical upper; + extern /* Subroutine */ void strmm_(char *, char *, char *, char *, + integer *, integer *, real *, real *, integer *, real *, integer * + ), ssyrk_(char *, char *, integer + *, integer *, real *, real *, integer *, real *, real *, integer * + ), slauu2_(char *, integer *, real *, integer *, + integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + +/* -- LAPACK auxiliary routine -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAUUM_BLOCKED", &i__1, (ftnlen)14); + return; + } + +/* Quick return if possible */ + + if (*n == 0) { + return; + } + +/* Determine the block size for this environment. */ + + nb = ilaenv_(&c__1, "SLAUUM_BLOCKED", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)14, (ftnlen)1); + + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + slauu2_(uplo, n, &a[a_offset], lda, info); + } else { + +/* Use blocked code */ + + if (upper) { + +/* Compute the product U * U**T. */ + + i__1 = *n; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - i__ + 1; + ib = f2cmin(i__3,i__4); + i__3 = i__ - 1; + strmm_("Right", "Upper", "Transpose", "Non-unit", &i__3, &ib, + &c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ * a_dim1 + + 1], lda) + ; + slauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); + if (i__ + ib <= *n) { + i__3 = i__ - 1; + i__4 = *n - i__ - ib + 1; + sgemm_("No transpose", "Transpose", &i__3, &ib, &i__4, & + c_b15, &a[(i__ + ib) * a_dim1 + 1], lda, &a[i__ + + (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ * + a_dim1 + 1], lda); + i__3 = *n - i__ - ib + 1; + ssyrk_("Upper", "No transpose", &ib, &i__3, &c_b15, &a[ + i__ + (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ + + i__ * a_dim1], lda); + } +/* L10: */ + } + } else { + +/* Compute the product L**T * L. */ + + i__2 = *n; + i__1 = nb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - i__ + 1; + ib = f2cmin(i__3,i__4); + i__3 = i__ - 1; + strmm_("Left", "Lower", "Transpose", "Non-unit", &ib, &i__3, & + c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ + a_dim1], + lda); + slauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); + if (i__ + ib <= *n) { + i__3 = i__ - 1; + i__4 = *n - i__ - ib + 1; + sgemm_("Transpose", "No transpose", &ib, &i__3, &i__4, & + c_b15, &a[i__ + ib + i__ * a_dim1], lda, &a[i__ + + ib + a_dim1], lda, &c_b15, &a[i__ + a_dim1], lda); + i__3 = *n - i__ - ib + 1; + ssyrk_("Lower", "Transpose", &ib, &i__3, &c_b15, &a[i__ + + ib + i__ * a_dim1], lda, &c_b15, &a[i__ + i__ * + a_dim1], lda); + } +/* L20: */ + } + } + } + + return; + +/* End of SLAUUM_BLOCKED */ + +} /* slauum_blocked__ */ + diff --git a/lapack-netlib/SRC/slauum_blocked.f b/lapack-netlib/SRC/slauum_blocked.f new file mode 100644 index 0000000000..94547cde2e --- /dev/null +++ b/lapack-netlib/SRC/slauum_blocked.f @@ -0,0 +1,212 @@ +*> \brief \b SLAUUM_BLOCKED computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SLAUUM_BLOCKED( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLAUUM_BLOCKED computes the product U * U**T or L**T * L, where the triangular +*> factor U or L is stored in the upper or lower triangular part of +*> the array A. +*> +*> If UPLO = 'U' or 'u' then the upper triangle of the result is stored, +*> overwriting the factor U in A, and the strictly lower triangular part +*> of A is not referenced. +*> If UPLO = 'L' or 'l' then the lower triangle of the result is stored, +*> overwriting the factor L in A, and the strictly upper triangular part +*> of A is not referenced. +*> +*> This is the blocked form of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the triangular factor stored in the array A +*> is upper or lower triangular: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the triangular factor U or L. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the triangular factor U or L. +*> On exit, if UPLO = 'U', the upper triangle of A is +*> overwritten with the upper triangle of the product U * U**T, +*> and the strictly lower triangular part of A is not referenced. +*> If UPLO = 'L', the lower triangle of A is overwritten with +*> the lower triangle of the product L**T * L, and the strictly +*> upper triangular part of A is not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lauum +* +* ===================================================================== + SUBROUTINE SLAUUM_BLOCKED( UPLO, N, A, LDA, INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + REAL A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IB, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SLAUU2, STRMM, SGEMM, SSYRK +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SLAUUM_BLOCKED', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'SLAUUM_BLOCKED', UPLO, N, -1, -1, -1 ) +* + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL SLAUU2( UPLO, N, A, LDA, INFO ) + ELSE +* +* Use blocked code +* + IF( UPPER ) THEN +* +* Compute the product U * U**T. +* + DO 10 I = 1, N, NB + IB = MIN( NB, N-I+1 ) + CALL STRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', + $ I-1, IB, ONE, A( I, I ), LDA, A( 1, I ), + $ LDA ) + CALL SLAUU2( 'Upper', IB, A( I, I ), LDA, INFO ) + IF( I+IB.LE.N ) THEN + CALL SGEMM( 'No transpose', 'Transpose', I-1, IB, + $ N-I-IB+1, ONE, A( 1, I+IB ), LDA, + $ A( I, I+IB ), LDA, ONE, A( 1, I ), LDA ) + CALL SSYRK( 'Upper', 'No transpose', IB, N-I-IB+1, + $ ONE, A( I, I+IB ), LDA, ONE, A( I, I ), + $ LDA ) + END IF + 10 CONTINUE + ELSE +* +* Compute the product L**T * L. +* + DO 20 I = 1, N, NB + IB = MIN( NB, N-I+1 ) + CALL STRMM( 'Left', 'Lower', 'Transpose', 'Non-unit', + $ IB, + $ I-1, ONE, A( I, I ), LDA, A( I, 1 ), LDA ) + CALL SLAUU2( 'Lower', IB, A( I, I ), LDA, INFO ) + IF( I+IB.LE.N ) THEN + CALL SGEMM( 'Transpose', 'No transpose', IB, I-1, + $ N-I-IB+1, ONE, A( I+IB, I ), LDA, + $ A( I+IB, 1 ), LDA, ONE, A( I, 1 ), LDA ) + CALL SSYRK( 'Lower', 'Transpose', IB, N-I-IB+1, + $ ONE, + $ A( I+IB, I ), LDA, ONE, A( I, I ), LDA ) + END IF + 20 CONTINUE + END IF + END IF +* + RETURN +* +* End of SLAUUM_BLOCKED +* + END diff --git a/lapack-netlib/SRC/slauum_recursive.c b/lapack-netlib/SRC/slauum_recursive.c new file mode 100644 index 0000000000..47bc5699f6 --- /dev/null +++ b/lapack-netlib/SRC/slauum_recursive.c @@ -0,0 +1,522 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#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_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)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#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 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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#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)} + +/* procedure parameter types for -A and -C++ */ + + +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + + +/* Table of constant values */ + +static integer c__3 = 3; +static integer c_n1 = -1; +static real c_b12 = 1.f; + +/* > \brief \b SLAUUM_ computes the product UUH or LHL, where U and L are upper or lower triangular matrices ( +recursive algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAUUM_( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAUUM_ computes the product U * U**T or L**T * L, where the triangular */ +/* > factor U or L is stored in the upper or lower triangular part of */ +/* > the array A. */ +/* > */ +/* > If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ +/* > overwriting the factor U in A, and the strictly lower triangular part */ +/* > of A is not referenced. */ +/* > If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ +/* > overwriting the factor L in A, and the strictly upper triangular part */ +/* > of A is not referenced. */ +/* > */ +/* > This is the recursive version of the algorithm */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the triangular factor stored in the array A */ +/* > is upper or lower triangular: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the triangular factor U or L. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the triangular factor U or L. */ +/* > On exit, if UPLO = 'U', the upper triangle of A is */ +/* > overwritten with the upper triangle of the product U * U**T, */ +/* > and the strictly lower triangular part of A is not referenced. */ +/* > If UPLO = 'L', the lower triangle of A is overwritten with */ +/* > the lower triangle of the product L**T * L, and the */ +/* > strictly upper triangular part of A is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup lauum */ + +/* ===================================================================== */ +/* Subroutine */ void slauum_recursive_(char *uplo, integer *n, real *a, integer *lda, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + integer k, nx; + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ void strmm_(char *, char *, char *, char *, + integer *, integer *, real *, real *, integer *, real *, integer * + ), ssyrk_(char *, char *, integer + *, integer *, real *, real *, integer *, real *, real *, integer * + ), slauu2_(char *, integer *, real *, integer *, + integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + +/* -- LAPACK auxiliary routine -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAUUM_RECURSIVE", &i__1, (ftnlen)16); + return; + } + +/* Early termination criteria */ + + if (*n == 0) { + return; + } + +/* Base Case */ + + if (*n == 1) { + a[a_dim1 + 1] *= a[a_dim1 + 1]; + return 0; + } + +/* Determine crossover point for when to bail to level2 */ + + nx = ilaenv_(&c__3, "SLAUUM_RECURSIVE", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)16, ( + ftnlen)1); + if (*n < nx) { + slauu2_(uplo, n, &a[a_offset], lda, info); + return; + } + +/* Beginning of executable statements for the recursive case */ + + k = *n / 2; + if (upper) { + +/* We are computing A = ut(U*U**T). */ + +/* Break apart U as follows */ +/* |-----------------| */ +/* U = | U_{11} U_{12} | */ +/* | 0 U_{22} | */ +/* |-----------------| */ + +/* Where */ +/* U_{11}\in\R^{k\times k} U_{12}\in\R^{ k\times n-k} */ +/* U_{22}\in\R^{n-k\times n-k} */ + +/* and U_{11},U_{22} are upper triangular and U_{12} is rectangular */ + +/* This gives us our operations as */ +/* |--------------------| |------------------------| */ +/* ut(U * U**T) = | U_{11} U_{12} | | U_{11}**T 0 | */ +/* | 0 U_{22} | | U_{12}**T U_{22}**T | */ +/* |--------------------| |------------------------| */ + +/* Thus we get */ + +/* U_{11} = U_{11}U_{11}**T + U_{12}U_{12}**T */ +/* U_{12} = U_{12}U_{22}**T */ + +/* U_{22} = U_{22}U_{22}**T */ + +/* We break these operations apart as follows */ + +/* U_{11} = U_{11}U_{11}**T (This subroutine) */ +/* U_{11} = U_{12}U_{12}**T + U_{11} (SYRK) */ + +/* U_{12} = U_{12}U_{22}**T (TRMM) */ + +/* U_{22} = U_{22}U_{22}**T (This subroutine) */ + + +/* Compute U_{11} */ + + slauum_recursive_(uplo, &k, &a[a_offset], lda, info); + i__1 = *n - k; + ssyrk_("Upper", "No Transpose", &k, &i__1, &c_b12, &a[(k + 1) * + a_dim1 + 1], lda, &c_b12, &a[a_offset], lda); + +/* Compute U_{12} */ + + i__1 = *n - k; + strmm_("Right", "Upper", "Transpose", "Non-unit", &k, &i__1, &c_b12, & + a[k + 1 + (k + 1) * a_dim1], lda, &a[(k + 1) * a_dim1 + 1], + lda); + +/* Compute U_{22} */ + + i__1 = *n - k; + slauum_recursive_(uplo, &i__1, &a[k + 1 + (k + 1) * a_dim1], lda, info); + } else { + +/* We are computing A = lt(L**T*L). */ + +/* Break apart L as follows */ +/* |-----------------| */ +/* L = | L_{11} 0 | */ +/* | L_{21} L_{22} | */ +/* |-----------------| */ + +/* Where */ +/* L_{11}\in\R^{ k\times k} */ +/* L_{21}\in\R^{n-k\times k} l_{22}\in\R^{n-k\times n-k} */ + +/* and L_{11},L_{22} are lower triangular and L_{21} is rectangular */ + +/* This gives us our operations as */ +/* |--------------------------| |-----------------| */ +/* lt(L**T * L) = | L_{11}**T L_{21}**T | | L_{11} 0 | */ +/* | 0 L_{22}**T | | L_{21} L_{22} | */ +/* |--------------------------| |-----------------| */ + +/* Thus we get */ + +/* L_{11} = L_{11}**T L_{11} + L_{21}**T L_{21} */ +/* L_{21} = L_{22}**T L_{21} */ + +/* L_{22} = L_{22}**T L_{22} */ + +/* We break these operations apart as follows */ + +/* L_{11} = L_{11}**T L_{11} (This subroutine) */ +/* L_{11} = L_{21}**T L_{21} + L_{11} (SYRK) */ + +/* L_{21} = L_{22}**T L_{21} (TRMM) */ + +/* L_{22} = L_{22}**T L_{22} (This subroutine) */ + + +/* Compute L_{11} */ + + slauum_recursive_(uplo, &k, &a[a_offset], lda, info); + i__1 = *n - k; + ssyrk_("Lower", "Transpose", &k, &i__1, &c_b12, &a[k + 1 + a_dim1], + lda, &c_b12, &a[a_offset], lda); + +/* Compute L_{21} */ + + i__1 = *n - k; + strmm_("Left", "Lower", "Transpose", "Non-Unit", &i__1, &k, &c_b12, & + a[k + 1 + (k + 1) * a_dim1], lda, &a[k + 1 + a_dim1], lda); + +/* Compute L_{22} */ + + i__1 = *n - k; + slauum_recursive_(uplo, &i__1, &a[k + 1 + (k + 1) * a_dim1], lda, info); + } + return; +} /* slauum___ */ + diff --git a/lapack-netlib/SRC/slauum_recursive.f b/lapack-netlib/SRC/slauum_recursive.f new file mode 100644 index 0000000000..d33d7a6843 --- /dev/null +++ b/lapack-netlib/SRC/slauum_recursive.f @@ -0,0 +1,277 @@ +*> \brief \b SLAUUM_RECURSIVE computes the product UUH or LHL, where U and L are upper or lower triangular matrices (recursive algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SLAUUM_RECURSIVE( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLAUUM_RECURSIVE computes the product U * U**T or L**T * L, where the triangular +*> factor U or L is stored in the upper or lower triangular part of +*> the array A. +*> +*> If UPLO = 'U' or 'u' then the upper triangle of the result is stored, +*> overwriting the factor U in A, and the strictly lower triangular part +*> of A is not referenced. +*> If UPLO = 'L' or 'l' then the lower triangle of the result is stored, +*> overwriting the factor L in A, and the strictly upper triangular part +*> of A is not referenced. +*> +*> This is the recursive version of the algorithm +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the triangular factor stored in the array A +*> is upper or lower triangular: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the triangular factor U or L. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the triangular factor U or L. +*> On exit, if UPLO = 'U', the upper triangle of A is +*> overwritten with the upper triangle of the product U * U**T, +*> and the strictly lower triangular part of A is not referenced. +*> If UPLO = 'L', the lower triangle of A is overwritten with +*> the lower triangle of the product L**T * L, and the +*> strictly upper triangular part of A is not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lauum +* +* ===================================================================== + RECURSIVE SUBROUTINE SLAUUM_RECURSIVE( UPLO, N, A, LDA, INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + REAL A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, NX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SLAUU2, SSYRK, STRMM +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SLAUUM_RECURSIVE', -INFO ) + RETURN + END IF +* +* Early termination criteria +* + IF( N.EQ.0 ) THEN + RETURN + END IF +* +* Base Case +* + IF( N.EQ.1 ) THEN + A(1,1) = A(1,1) * A(1,1) + RETURN + END IF +* +* Determine crossover point for when to bail to level2 +* + NX = ILAENV(3, "SLAUUM_RECURSIVE", UPLO, N, -1, -1, -1) + IF( N.LT.NX ) THEN + CALL SLAUU2(UPLO, N, A, LDA, INFO) + RETURN + END IF +* +* Beginning of executable statements for the recursive case +* + K = N/2 + IF( UPPER ) THEN +* +* We are computing A = ut(U*U**T). +* +* Break apart U as follows +* |-----------------| +* U = | U_{11} U_{12} | +* | 0 U_{22} | +* |-----------------| +* +* Where +* U_{11}\in\R^{k\times k} U_{12}\in\R^{ k\times n-k} +* U_{22}\in\R^{n-k\times n-k} +* +* and U_{11},U_{22} are upper triangular and U_{12} is rectangular +* +* This gives us our operations as +* |--------------------| |------------------------| +* ut(U * U**T) = | U_{11} U_{12} | | U_{11}**T 0 | +* | 0 U_{22} | | U_{12}**T U_{22}**T | +* |--------------------| |------------------------| +* +* Thus we get +* +* U_{11} = U_{11}U_{11}**T + U_{12}U_{12}**T +* U_{12} = U_{12}U_{22}**T +* +* U_{22} = U_{22}U_{22}**T +* +* We break these operations apart as follows +* +* U_{11} = U_{11}U_{11}**T (This subroutine) +* U_{11} = U_{12}U_{12}**T + U_{11} (SYRK) +* +* U_{12} = U_{12}U_{22}**T (TRMM) +* +* U_{22} = U_{22}U_{22}**T (This subroutine) +* +* +* Compute U_{11} +* + CALL SLAUUM_RECURSIVE(UPLO, K, A, LDA, INFO) + CALL SSYRK('Upper', 'No Transpose', K, N-K, + $ ONE, A(1,K+1), LDA, ONE, A, LDA) +* +* Compute U_{12} +* + CALL STRMM('Right', 'Upper', 'Transpose', 'Non-unit', + $ K, N-K, ONE, A(K+1,K+1), LDA, A(1,K+1), LDA) +* +* Compute U_{22} +* + CALL SLAUUM_RECURSIVE(UPLO, N-K, A(K+1,K+1), LDA, INFO) + ELSE +* +* We are computing A = lt(L**T*L). +* +* Break apart L as follows +* |-----------------| +* L = | L_{11} 0 | +* | L_{21} L_{22} | +* |-----------------| +* +* Where +* L_{11}\in\R^{ k\times k} +* L_{21}\in\R^{n-k\times k} l_{22}\in\R^{n-k\times n-k} +* +* and L_{11},L_{22} are lower triangular and L_{21} is rectangular +* +* This gives us our operations as +* |--------------------------| |-----------------| +* lt(L**T * L) = | L_{11}**T L_{21}**T | | L_{11} 0 | +* | 0 L_{22}**T | | L_{21} L_{22} | +* |--------------------------| |-----------------| +* +* Thus we get +* +* L_{11} = L_{11}**T L_{11} + L_{21}**T L_{21} +* L_{21} = L_{22}**T L_{21} +* +* L_{22} = L_{22}**T L_{22} +* +* We break these operations apart as follows +* +* L_{11} = L_{11}**T L_{11} (This subroutine) +* L_{11} = L_{21}**T L_{21} + L_{11} (SYRK) +* +* L_{21} = L_{22}**T L_{21} (TRMM) +* +* L_{22} = L_{22}**T L_{22} (This subroutine) +* +* +* Compute L_{11} +* + CALL SLAUUM_RECURSIVE(UPLO, K, A, LDA, INFO) + CALL SSYRK('Lower', 'Transpose', K, N-K, + $ ONE, A(K+1,1), LDA, ONE, A, LDA) +* +* Compute L_{21} +* + CALL STRMM('Left', 'Lower', 'Transpose', 'Non-Unit', + $ N-K, K, ONE, A(K+1,K+1), LDA, A(K+1,1), LDA) +* +* Compute L_{22} +* + CALL SLAUUM_RECURSIVE(UPLO, N-K, A(K+1,K+1), LDA, INFO) + END IF + END SUBROUTINE diff --git a/lapack-netlib/SRC/zlauu2.c b/lapack-netlib/SRC/zlauu2.c index 124fdd5a83..3169107c76 100644 --- a/lapack-netlib/SRC/zlauu2.c +++ b/lapack-netlib/SRC/zlauu2.c @@ -411,10 +411,6 @@ static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integ -lf2c -lm (in that order) */ - - - - /* Table of constant values */ static doublecomplex c_b1 = {1.,0.}; @@ -428,7 +424,6 @@ nblocked algorithm). */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ZLAUU2 + dependencies */ /* > */ @@ -439,7 +434,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -493,7 +487,9 @@ f"> */ /* > On exit, if UPLO = 'U', the upper triangle of A is */ /* > overwritten with the upper triangle of the product U * U**H; */ /* > if UPLO = 'L', the lower triangle of A is overwritten with */ -/* > the lower triangle of the product L**H * L. */ +/* > the lower triangle of the product L**H * L. Regardless, */ +/* > the diagonal elements are explicitly set to be real by casting */ +/* . to DBLE before exit. */ /* > \endverbatim */ /* > */ /* > \param[in] LDA */ @@ -517,9 +513,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complex16OTHERauxiliary */ +/* > \ingroup lauu2 */ /* ===================================================================== */ /* Subroutine */ void zlauu2_(char *uplo, integer *n, doublecomplex *a, @@ -531,25 +525,21 @@ f"> */ doublecomplex z__1; /* Local variables */ - integer i__; + integer i__, j; + doublecomplex aii, ajj; extern logical lsame_(char *, char *); - extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, - doublecomplex *, integer *, doublecomplex *, integer *); - extern /* Subroutine */ void zgemv_(char *, integer *, integer *, - doublecomplex *, doublecomplex *, integer *, doublecomplex *, - integer *, doublecomplex *, doublecomplex *, integer *); + extern /* Subroutine */ void zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), zgemm_(char *, char *, integer *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); logical upper; extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - extern void zdscal_( - integer *, doublereal *, doublecomplex *, integer *), zlacgv_( - integer *, doublecomplex *, integer *); - doublereal aii; -/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK auxiliary routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -559,7 +549,7 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ @@ -589,30 +579,30 @@ f"> */ /* Compute the product U * U**H. */ i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__ + i__ * a_dim1; - aii = a[i__2].r; - if (i__ < *n) { - i__2 = i__ + i__ * a_dim1; - i__3 = *n - i__; - zdotc_(&z__1, &i__3, &a[i__ + (i__ + 1) * a_dim1], lda, &a[ - i__ + (i__ + 1) * a_dim1], lda); - d__1 = aii * aii + z__1.r; - a[i__2].r = d__1, a[i__2].i = 0.; - i__2 = *n - i__; - zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); - i__2 = i__ - 1; - i__3 = *n - i__; - z__1.r = aii, z__1.i = 0.; - zgemv_("No transpose", &i__2, &i__3, &c_b1, &a[(i__ + 1) * - a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, & - z__1, &a[i__ * a_dim1 + 1], &c__1); - i__2 = *n - i__; - zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); + for (j = 1; j <= i__1; ++j) { + d_cnjg(&z__1, &a[j + j * a_dim1]); + ajj.r = z__1.r, ajj.i = z__1.i; + if (j == *n) { + +/* We have this case separate just to ensure we never */ +/* access A out of bounds when we do A(J,J+1) = A(N,N+1) */ + + zscal_(n, &ajj, &a[*n * a_dim1 + 1], &c__1); } else { - zdscal_(&i__, &aii, &a[i__ * a_dim1 + 1], &c__1); + i__2 = *n - j; + zgemm_("No Transpose", "Conjugate Transpose", &j, &c__1, & + i__2, &c_b1, &a[(j + 1) * a_dim1 + 1], lda, &a[j + (j + + 1) * a_dim1], lda, &ajj, &a[j * a_dim1 + 1], lda); } -/* L10: */ + +/* Since in exact arithmetic the diagonal will be real on output */ +/* we explicitly cast the diagonal to real (zero out the */ +/* imaginary component) */ + + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; } } else { @@ -621,29 +611,29 @@ f"> */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { - i__2 = i__ + i__ * a_dim1; - aii = a[i__2].r; - if (i__ < *n) { - i__2 = i__ + i__ * a_dim1; - i__3 = *n - i__; - zdotc_(&z__1, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[ - i__ + 1 + i__ * a_dim1], &c__1); - d__1 = aii * aii + z__1.r; - a[i__2].r = d__1, a[i__2].i = 0.; - i__2 = i__ - 1; - zlacgv_(&i__2, &a[i__ + a_dim1], lda); - i__2 = *n - i__; - i__3 = i__ - 1; - z__1.r = aii, z__1.i = 0.; - zgemv_("Conjugate transpose", &i__2, &i__3, &c_b1, &a[i__ + 1 - + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, & - z__1, &a[i__ + a_dim1], lda); - i__2 = i__ - 1; - zlacgv_(&i__2, &a[i__ + a_dim1], lda); + d_cnjg(&z__1, &a[i__ + i__ * a_dim1]); + aii.r = z__1.r, aii.i = z__1.i; + if (i__ == *n) { + +/* We have this case separate just to ensure we never */ +/* access A out of bounds when we do A(I+1,I) = A(N+1,N) */ + + zscal_(n, &aii, &a[*n + a_dim1], lda); } else { - zdscal_(&i__, &aii, &a[i__ + a_dim1], lda); + i__2 = *n - i__; + zgemm_("Conjugate Transpose", "No Transpose", &c__1, &i__, & + i__2, &c_b1, &a[i__ + 1 + i__ * a_dim1], lda, &a[i__ + + 1 + a_dim1], lda, &aii, &a[i__ + a_dim1], lda); } -/* L20: */ + +/* Since in exact arithmetic the diagonal will be real on output */ +/* we explicitly cast the diagonal to real (zero out the */ +/* imaginary component) */ + + i__2 = i__ + i__ * a_dim1; + i__3 = i__ + i__ * a_dim1; + d__1 = a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; } } diff --git a/lapack-netlib/SRC/zlauu2.f b/lapack-netlib/SRC/zlauu2.f index 7d7faebdf5..fac1722d30 100644 --- a/lapack-netlib/SRC/zlauu2.f +++ b/lapack-netlib/SRC/zlauu2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZLAUU2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -71,7 +69,9 @@ *> On exit, if UPLO = 'U', the upper triangle of A is *> overwritten with the upper triangle of the product U * U**H; *> if UPLO = 'L', the lower triangle of A is overwritten with -*> the lower triangle of the product L**H * L. +*> the lower triangle of the product L**H * L. Regardless, +*> the diagonal elements are explicitly set to be real by casting +*. to DBLE before exit. *> \endverbatim *> *> \param[in] LDA @@ -95,10 +95,11 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16OTHERauxiliary +*> \ingroup lauu2 * * ===================================================================== SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -120,19 +121,18 @@ SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO ) * .. * .. Local Scalars .. LOGICAL UPPER - INTEGER I - DOUBLE PRECISION AII + INTEGER I, J + COMPLEX*16 AII, AJJ * .. * .. External Functions .. LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC + EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZDSCAL, ZGEMV, ZLACGV + EXTERNAL XERBLA, ZSCAL, ZGEMM * .. * .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, MAX + INTRINSIC DBLE, DCONJG, MAX * .. * .. Executable Statements .. * @@ -161,39 +161,51 @@ SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO ) * * Compute the product U * U**H. * - DO 10 I = 1, N - AII = DBLE( A( I, I ) ) - IF( I.LT.N ) THEN - A( I, I ) = AII*AII + DBLE( ZDOTC( N-I, A( I, I+1 ), LDA, - $ A( I, I+1 ), LDA ) ) - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - CALL ZGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), - $ LDA, A( I, I+1 ), LDA, DCMPLX( AII ), - $ A( 1, I ), 1 ) - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) + DO J = 1, N + AJJ = DCONJG(A(J,J)) + IF( J.EQ.N ) THEN +* +* We have this case separate just to ensure we never +* access A out of bounds when we do A(J,J+1) = A(N,N+1) +* + CALL ZSCAL( N, AJJ, A(1,N), 1 ) ELSE - CALL ZDSCAL( I, AII, A( 1, I ), 1 ) + CALL ZGEMM('No Transpose', 'Conjugate Transpose', + $ J, 1, N-J, ONE, A(1,J+1), LDA, A(J,J+1), LDA, + $ AJJ, A(1,J), LDA) END IF - 10 CONTINUE +* +* Since in exact arithmetic the diagonal will be real on output +* we explicitly cast the diagonal to real (zero out the +* imaginary component) +* + A(J,J) = DBLE(A(J,J)) + END DO * ELSE * * Compute the product L**H * L. * - DO 20 I = 1, N - AII = DBLE( A( I, I ) ) - IF( I.LT.N ) THEN - A( I, I ) = AII*AII + DBLE( ZDOTC( N-I, A( I+1, I ), 1, - $ A( I+1, I ), 1 ) ) - CALL ZLACGV( I-1, A( I, 1 ), LDA ) - CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE, - $ A( I+1, 1 ), LDA, A( I+1, I ), 1, - $ DCMPLX( AII ), A( I, 1 ), LDA ) - CALL ZLACGV( I-1, A( I, 1 ), LDA ) + DO I = 1, N + AII = DCONJG(A(I,I)) + IF( I.EQ.N ) THEN +* +* We have this case separate just to ensure we never +* access A out of bounds when we do A(I+1,I) = A(N+1,N) +* + CALL ZSCAL(N, AII, A(N,1), LDA) ELSE - CALL ZDSCAL( I, AII, A( I, 1 ), LDA ) + CALL ZGEMM('Conjugate Transpose', 'No Transpose', + $ 1, I, N-I, ONE, A(I+1,I), LDA, A(I+1,1), LDA, + $ AII, A(I,1), LDA) END IF - 20 CONTINUE +* +* Since in exact arithmetic the diagonal will be real on output +* we explicitly cast the diagonal to real (zero out the +* imaginary component) +* + A(I,I) = DBLE(A(I,I)) + END DO END IF * RETURN diff --git a/lapack-netlib/SRC/zlauum.c b/lapack-netlib/SRC/zlauum.c index 1cf147edbc..cf0fee3a8a 100644 --- a/lapack-netlib/SRC/zlauum.c +++ b/lapack-netlib/SRC/zlauum.c @@ -529,20 +529,15 @@ static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integ /* Table of constant values */ -static doublecomplex c_b1 = {1.,0.}; -static integer c__1 = 1; -static integer c_n1 = -1; -static doublereal c_b21 = 1.; -/* > \brief \b ZLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (b -locked algorithm). */ +/* > \brief \b ZLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (d +river algorithm). */ /* =========== DOCUMENTATION =========== */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ZLAUUM + dependencies */ /* > */ @@ -553,7 +548,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -575,11 +569,13 @@ f"> */ /* > the array A. */ /* > */ /* > If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ -/* > overwriting the factor U in A. */ +/* > overwriting the factor U in A, and the strictly lower triangular part */ +/* > of A is not referenced. */ /* > If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ -/* > overwriting the factor L in A. */ +/* > overwriting the factor L in A, and the strictly upper triangular part */ +/* > of A is not referenced. */ /* > */ -/* > This is the blocked form of the algorithm, calling Level 3 BLAS. */ +/* > This is the driver that dispatches to either blocked or recursive */ /* > \endverbatim */ /* Arguments: */ @@ -605,9 +601,13 @@ f"> */ /* > A is COMPLEX*16 array, dimension (LDA,N) */ /* > On entry, the triangular factor U or L. */ /* > On exit, if UPLO = 'U', the upper triangle of A is */ -/* > overwritten with the upper triangle of the product U * U**H; */ -/* > if UPLO = 'L', the lower triangle of A is overwritten with */ -/* > the lower triangle of the product L**H * L. */ +/* > overwritten with the upper triangle of the product U * U**H, */ +/* > and the strictly lower triangular part of A is not referenced. */ +/* > If UPLO = 'L', the lower triangle of A is overwritten with */ +/* > the lower triangle of the product L**H * L, and the strictly */ +/* > upper triangular part of A is not referenced. Regardless, */ +/* > the diagonal elements are explicitly set to be real by casting */ +/* . to DBLE before exit. */ /* > \endverbatim */ /* > */ /* > \param[in] LDA */ @@ -631,42 +631,25 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complex16OTHERauxiliary */ +/* > \ingroup lauum */ /* ===================================================================== */ /* Subroutine */ void zlauum_(char *uplo, integer *n, doublecomplex *a, integer *lda, 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; /* Local variables */ - integer i__; extern logical lsame_(char *, char *); - extern /* Subroutine */ void zgemm_(char *, char *, integer *, integer *, - integer *, doublecomplex *, doublecomplex *, integer *, - doublecomplex *, integer *, doublecomplex *, doublecomplex *, - integer *), zherk_(char *, char *, integer *, - integer *, doublereal *, doublecomplex *, integer *, doublereal *, - doublecomplex *, integer *); logical upper; - extern /* Subroutine */ void ztrmm_(char *, char *, char *, char *, - integer *, integer *, doublecomplex *, doublecomplex *, integer *, - doublecomplex *, integer *); - integer ib, nb; - extern /* Subroutine */ void zlauu2_(char *, integer *, doublecomplex *, - integer *, integer *); - extern void xerbla_(char *, integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - - -/* -- LAPACK auxiliary routine (version 3.7.0) -- */ + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), zlauum_recursive_( + char *, integer *, doublecomplex *, integer *, integer *); + + +/* -- LAPACK auxiliary routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -676,7 +659,7 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ @@ -701,81 +684,13 @@ f"> */ return; } -/* Determine the block size for this environment. */ - - nb = ilaenv_(&c__1, "ZLAUUM", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( - ftnlen)1); - - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code */ - - zlauu2_(uplo, n, &a[a_offset], lda, info); - } else { - -/* Use blocked code */ - - if (upper) { - -/* Compute the product U * U**H. */ - - i__1 = *n; - i__2 = nb; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__3 = nb, i__4 = *n - i__ + 1; - ib = f2cmin(i__3,i__4); - i__3 = i__ - 1; - ztrmm_("Right", "Upper", "Conjugate transpose", "Non-unit", & - i__3, &ib, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__ - * a_dim1 + 1], lda); - zlauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); - if (i__ + ib <= *n) { - i__3 = i__ - 1; - i__4 = *n - i__ - ib + 1; - zgemm_("No transpose", "Conjugate transpose", &i__3, &ib, - &i__4, &c_b1, &a[(i__ + ib) * a_dim1 + 1], lda, & - a[i__ + (i__ + ib) * a_dim1], lda, &c_b1, &a[i__ * - a_dim1 + 1], lda); - i__3 = *n - i__ - ib + 1; - zherk_("Upper", "No transpose", &ib, &i__3, &c_b21, &a[ - i__ + (i__ + ib) * a_dim1], lda, &c_b21, &a[i__ + - i__ * a_dim1], lda); - } -/* L10: */ - } - } else { - -/* Compute the product L**H * L. */ - - i__2 = *n; - i__1 = nb; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { -/* Computing MIN */ - i__3 = nb, i__4 = *n - i__ + 1; - ib = f2cmin(i__3,i__4); - i__3 = i__ - 1; - ztrmm_("Left", "Lower", "Conjugate transpose", "Non-unit", & - ib, &i__3, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__ - + a_dim1], lda); - zlauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); - if (i__ + ib <= *n) { - i__3 = i__ - 1; - i__4 = *n - i__ - ib + 1; - zgemm_("Conjugate transpose", "No transpose", &ib, &i__3, - &i__4, &c_b1, &a[i__ + ib + i__ * a_dim1], lda, & - a[i__ + ib + a_dim1], lda, &c_b1, &a[i__ + a_dim1] - , lda); - i__3 = *n - i__ - ib + 1; - zherk_("Lower", "Conjugate transpose", &ib, &i__3, &c_b21, - &a[i__ + ib + i__ * a_dim1], lda, &c_b21, &a[i__ - + i__ * a_dim1], lda); - } -/* L20: */ - } - } - } +/* Here we dispatch to whatever is more efficient in a particular environment */ +/* We are defaulting to recursive, but if you want to use the blocked variant */ +/* Comment out the line starting with `CALL ZLAUUM_...` */ +/* and uncomment the line starting with `CALL ZLAUUM_BLOCKED...` */ + zlauum_recursive_(uplo, n, &a[a_offset], lda, info); + //zlauum_bblocked_(uplo, n, &a[a_offset], lda, info); return; /* End of ZLAUUM */ diff --git a/lapack-netlib/SRC/zlauum.f b/lapack-netlib/SRC/zlauum.f index af36aa92df..9431618658 100644 --- a/lapack-netlib/SRC/zlauum.f +++ b/lapack-netlib/SRC/zlauum.f @@ -1,11 +1,10 @@ -*> \brief \b ZLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm). +*> \brief \b ZLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (driver algorithm). * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZLAUUM + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -39,11 +37,13 @@ *> the array A. *> *> If UPLO = 'U' or 'u' then the upper triangle of the result is stored, -*> overwriting the factor U in A. +*> overwriting the factor U in A, and the strictly lower triangular part +*> of A is not referenced. *> If UPLO = 'L' or 'l' then the lower triangle of the result is stored, -*> overwriting the factor L in A. +*> overwriting the factor L in A, and the strictly upper triangular part +*> of A is not referenced. *> -*> This is the blocked form of the algorithm, calling Level 3 BLAS. +*> This is the driver that dispatches to either blocked or recursive *> \endverbatim * * Arguments: @@ -69,9 +69,13 @@ *> A is COMPLEX*16 array, dimension (LDA,N) *> On entry, the triangular factor U or L. *> On exit, if UPLO = 'U', the upper triangle of A is -*> overwritten with the upper triangle of the product U * U**H; -*> if UPLO = 'L', the lower triangle of A is overwritten with -*> the lower triangle of the product L**H * L. +*> overwritten with the upper triangle of the product U * U**H, +*> and the strictly lower triangular part of A is not referenced. +*> If UPLO = 'L', the lower triangle of A is overwritten with +*> the lower triangle of the product L**H * L, and the strictly +*> upper triangular part of A is not referenced. Regardless, +*> the diagonal elements are explicitly set to be real by casting +*. to DBLE before exit. *> \endverbatim *> *> \param[in] LDA @@ -95,10 +99,11 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16OTHERauxiliary +*> \ingroup lauum * * ===================================================================== SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -114,26 +119,20 @@ SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO ) * * ===================================================================== * -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL UPPER - INTEGER I, IB, NB * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV + EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL XERBLA, ZGEMM, ZHERK, ZLAUU2, ZTRMM + EXTERNAL XERBLA, ZLAUUM_RECURSIVE, + $ ZLAUUM_BLOCKED * .. * .. Intrinsic Functions .. - INTRINSIC MAX, MIN + INTRINSIC MAX * .. * .. Executable Statements .. * @@ -158,61 +157,13 @@ SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO ) IF( N.EQ.0 ) $ RETURN * -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'ZLAUUM', UPLO, N, -1, -1, -1 ) -* - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL ZLAUU2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute the product U * U**H. -* - DO 10 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Non-unit', I-1, IB, CONE, A( I, I ), LDA, - $ A( 1, I ), LDA ) - CALL ZLAUU2( 'Upper', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ I-1, IB, N-I-IB+1, CONE, A( 1, I+IB ), - $ LDA, A( I, I+IB ), LDA, CONE, A( 1, I ), - $ LDA ) - CALL ZHERK( 'Upper', 'No transpose', IB, N-I-IB+1, - $ ONE, A( I, I+IB ), LDA, ONE, A( I, I ), - $ LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the product L**H * L. -* - DO 20 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL ZTRMM( 'Left', 'Lower', 'Conjugate transpose', - $ 'Non-unit', IB, I-1, CONE, A( I, I ), LDA, - $ A( I, 1 ), LDA ) - CALL ZLAUU2( 'Lower', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL ZGEMM( 'Conjugate transpose', 'No transpose', IB, - $ I-1, N-I-IB+1, CONE, A( I+IB, I ), LDA, - $ A( I+IB, 1 ), LDA, CONE, A( I, 1 ), LDA ) - CALL ZHERK( 'Lower', 'Conjugate transpose', IB, - $ N-I-IB+1, ONE, A( I+IB, I ), LDA, ONE, - $ A( I, I ), LDA ) - END IF - 20 CONTINUE - END IF - END IF +* Here we dispatch to whatever is more efficient in a particular environment +* We are defaulting to recursive, but if you want to use the blocked variant +* Comment out the line starting with `CALL ZLAUUM_RECURSIVE...` +* and uncomment the line starting with `CALL ZLAUUM_BLOCKED...` * + CALL ZLAUUM_RECURSIVE(UPLO, N, A, LDA, INFO) +* CALL ZLAUUM_BLOCKED(UPLO, N, A, LDA, INFO) RETURN * * End of ZLAUUM diff --git a/lapack-netlib/SRC/zlauum_blocked.c b/lapack-netlib/SRC/zlauum_blocked.c new file mode 100644 index 0000000000..cb77ec7ada --- /dev/null +++ b/lapack-netlib/SRC/zlauum_blocked.c @@ -0,0 +1,771 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#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));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#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)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#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 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 + +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 \brief \b ZLAUUM_BLOCKED computes the product UUH or LHL, where U and L are upper or lower triangular mat +rices (blocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAUUM_BLOCKED( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAUUM_BLOCKED computes the product U * U**H or L**H * L, where the triangular */ +/* > factor U or L is stored in the upper or lower triangular part of */ +/* > the array A. */ +/* > */ +/* > If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ +/* > overwriting the factor U in A, and the strictly lower triangular part */ +/* > of A is not referenced. */ +/* > If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ +/* > overwriting the factor L in A, and the strictly upper triangular part */ +/* > of A is not referenced. */ +/* > */ +/* > This is the blocked form of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the triangular factor stored in the array A */ +/* > is upper or lower triangular: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the triangular factor U or L. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the triangular factor U or L. */ +/* > On exit, if UPLO = 'U', the upper triangle of A is */ +/* > overwritten with the upper triangle of the product U * U**H, */ +/* > and the strictly lower triangular part of A is not referenced. */ +/* > If UPLO = 'L', the lower triangle of A is overwritten with */ +/* > the lower triangle of the product L**H * L, and the strictly */ +/* > upper triangular part of A is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup lauum */ + +/* ===================================================================== */ +/* Subroutine */ void zlauum_blocked_(char *uplo, integer *n, doublecomplex * + a, integer *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, ib, nb; + extern logical lsame_(char *, char *); + extern /* Subroutine */ void zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *), zherk_(char *, char *, integer *, + integer *, doublereal *, doublecomplex *, integer *, doublereal *, + doublecomplex *, integer *); + logical upper; + extern /* Subroutine */ void ztrmm_(char *, char *, char *, char *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *), + zlauu2_(char *, integer *, doublecomplex *, integer *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + +/* -- LAPACK auxiliary routine -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLAUUM_BLOCKED", &i__1, (ftnlen)14); + return; + } + +/* Quick return if possible */ + + if (*n == 0) { + return; + } + +/* Determine the block size for this environment. */ + + nb = ilaenv_(&c__1, "ZLAUUM_BLOCKED", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)14, (ftnlen)1); + + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + zlauu2_(uplo, n, &a[a_offset], lda, info); + } else { + +/* Use blocked code */ + + if (upper) { + +/* Compute the product U * U**H. */ + + i__1 = *n; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - i__ + 1; + ib = f2cmin(i__3,i__4); + i__3 = i__ - 1; + ztrmm_("Right", "Upper", "Conjugate transpose", "Non-unit", & + i__3, &ib, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__ + * a_dim1 + 1], lda); + zlauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); + if (i__ + ib <= *n) { + i__3 = i__ - 1; + i__4 = *n - i__ - ib + 1; + zgemm_("No transpose", "Conjugate transpose", &i__3, &ib, + &i__4, &c_b1, &a[(i__ + ib) * a_dim1 + 1], lda, & + a[i__ + (i__ + ib) * a_dim1], lda, &c_b1, &a[i__ * + a_dim1 + 1], lda); + i__3 = *n - i__ - ib + 1; + zherk_("Upper", "No transpose", &ib, &i__3, &c_b21, &a[ + i__ + (i__ + ib) * a_dim1], lda, &c_b21, &a[i__ + + i__ * a_dim1], lda); + } +/* L10: */ + } + } else { + +/* Compute the product L**H * L. */ + + i__2 = *n; + i__1 = nb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - i__ + 1; + ib = f2cmin(i__3,i__4); + i__3 = i__ - 1; + ztrmm_("Left", "Lower", "Conjugate transpose", "Non-unit", & + ib, &i__3, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__ + + a_dim1], lda); + zlauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); + if (i__ + ib <= *n) { + i__3 = i__ - 1; + i__4 = *n - i__ - ib + 1; + zgemm_("Conjugate transpose", "No transpose", &ib, &i__3, + &i__4, &c_b1, &a[i__ + ib + i__ * a_dim1], lda, & + a[i__ + ib + a_dim1], lda, &c_b1, &a[i__ + a_dim1] + , lda); + i__3 = *n - i__ - ib + 1; + zherk_("Lower", "Conjugate transpose", &ib, &i__3, &c_b21, + &a[i__ + ib + i__ * a_dim1], lda, &c_b21, &a[i__ + + i__ * a_dim1], lda); + } +/* L20: */ + } + } + } + + return; + +/* End of ZLAUUM_BLOCKED */ + +} /* zlauum_blocked__ */ + diff --git a/lapack-netlib/SRC/zlauum_blocked.f b/lapack-netlib/SRC/zlauum_blocked.f new file mode 100644 index 0000000000..1a96b79fa4 --- /dev/null +++ b/lapack-netlib/SRC/zlauum_blocked.f @@ -0,0 +1,216 @@ +*> \brief \b ZLAUUM_BLOCKED computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZLAUUM_BLOCKED( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAUUM_BLOCKED computes the product U * U**H or L**H * L, where the triangular +*> factor U or L is stored in the upper or lower triangular part of +*> the array A. +*> +*> If UPLO = 'U' or 'u' then the upper triangle of the result is stored, +*> overwriting the factor U in A, and the strictly lower triangular part +*> of A is not referenced. +*> If UPLO = 'L' or 'l' then the lower triangle of the result is stored, +*> overwriting the factor L in A, and the strictly upper triangular part +*> of A is not referenced. +*> +*> This is the blocked form of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the triangular factor stored in the array A +*> is upper or lower triangular: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the triangular factor U or L. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the triangular factor U or L. +*> On exit, if UPLO = 'U', the upper triangle of A is +*> overwritten with the upper triangle of the product U * U**H, +*> and the strictly lower triangular part of A is not referenced. +*> If UPLO = 'L', the lower triangle of A is overwritten with +*> the lower triangle of the product L**H * L, and the strictly +*> upper triangular part of A is not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lauum +* +* ===================================================================== + SUBROUTINE ZLAUUM_BLOCKED( UPLO, N, A, LDA, INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) + COMPLEX*16 ZONE + PARAMETER ( ZONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IB, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLAUU2, ZTRMM, ZGEMM, ZHERK +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLAUUM_BLOCKED', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'ZLAUUM_BLOCKED', UPLO, N, -1, -1, -1 ) +* + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL ZLAUU2( UPLO, N, A, LDA, INFO ) + ELSE +* +* Use blocked code +* + IF( UPPER ) THEN +* +* Compute the product U * U**H. +* + DO 10 I = 1, N, NB + IB = MIN( NB, N-I+1 ) + CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', + $ 'Non-unit', I-1, IB, ZONE, A( I, I ), LDA, + $ A( 1, I ), LDA ) + CALL ZLAUU2( 'Upper', IB, A( I, I ), LDA, INFO ) + IF( I+IB.LE.N ) THEN + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ I-1, IB, N-I-IB+1, ZONE, A( 1, I+IB ), + $ LDA, A( I, I+IB ), LDA, ZONE, A( 1, I ), + $ LDA ) + CALL ZHERK( 'Upper', 'No transpose', IB, N-I-IB+1, + $ ONE, A( I, I+IB ), LDA, ONE, A( I, I ), + $ LDA ) + END IF + 10 CONTINUE + ELSE +* +* Compute the product L**H * L. +* + DO 20 I = 1, N, NB + IB = MIN( NB, N-I+1 ) + CALL ZTRMM( 'Left', 'Lower', 'Conjugate transpose', + $ 'Non-unit', IB, I-1, ZONE, A( I, I ), LDA, + $ A( I, 1 ), LDA ) + CALL ZLAUU2( 'Lower', IB, A( I, I ), LDA, INFO ) + IF( I+IB.LE.N ) THEN + CALL ZGEMM( 'Conjugate transpose', 'No transpose', + $ IB, + $ I-1, N-I-IB+1, ZONE, A( I+IB, I ), LDA, + $ A( I+IB, 1 ), LDA, ZONE, A( I, 1 ), LDA ) + CALL ZHERK( 'Lower', 'Conjugate transpose', IB, + $ N-I-IB+1, ONE, A( I+IB, I ), LDA, ONE, + $ A( I, I ), LDA ) + END IF + 20 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZLAUUM_BLOCKED +* + END diff --git a/lapack-netlib/SRC/zlauum_recursive.c b/lapack-netlib/SRC/zlauum_recursive.c new file mode 100644 index 0000000000..eb58ee1633 --- /dev/null +++ b/lapack-netlib/SRC/zlauum_recursive.c @@ -0,0 +1,834 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#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));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#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)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#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 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 + +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 \brief \b ZLAUUM_ computes the product UUH or LHL, where U and L are upper or lower triangular matrices ( +recursive algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAUUM_( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAUUM_ computes the product U * U**H or L**H * L, where the triangular */ +/* > factor U or L is stored in the upper or lower triangular part of */ +/* > the array A. */ +/* > */ +/* > If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ +/* > overwriting the factor U in A, and the strictly lower triangular part */ +/* > of A is not referenced. */ +/* > If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ +/* > overwriting the factor L in A, and the strictly upper triangular part */ +/* > of A is not referenced. */ +/* > */ +/* > This is the recursive version of the algorithm */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the triangular factor stored in the array A */ +/* > is upper or lower triangular: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the triangular factor U or L. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the triangular factor U or L. */ +/* > On exit, if UPLO = 'U', the upper triangle of A is */ +/* > overwritten with the upper triangle of the product U * U**H, */ +/* > and the strictly lower triangular part of A is not referenced. */ +/* > If UPLO = 'L', the lower triangle of A is overwritten with */ +/* > the lower triangle of the product L**H * L, and the */ +/* > strictly upper triangular part of A is not referenced. Regardless, */ +/* > the diagonal elements are explicitly set to be real by casting */ +/* . to DBLE before exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup lauum */ + +/* ===================================================================== */ +/* Subroutine */ void zlauum_recursive_(char *uplo, integer *n, doublecomplex *a, + integer *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1; + doublecomplex z__1, z__2; + + /* Local variables */ + integer k, nx; + extern logical lsame_(char *, char *); + extern /* Subroutine */ void zherk_(char *, char *, integer *, integer *, + doublereal *, doublecomplex *, integer *, doublereal *, + doublecomplex *, integer *); + logical upper; + extern /* Subroutine */ void ztrmm_(char *, char *, char *, char *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *), + zlauu2_(char *, integer *, doublecomplex *, integer *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + +/* -- LAPACK auxiliary routine -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLAUUM_RECURSIVE", &i__1, (ftnlen)16); + return; + } + +/* Early termination criteria */ + + if (*n == 0) { + return; + } + +/* Base Case */ + + if (*n == 1) { + i__1 = a_dim1 + 1; + i__2 = a_dim1 + 1; + d_cnjg(&z__2, &a[a_dim1 + 1]); + z__1.r = a[i__2].r * z__2.r - a[i__2].i * z__2.i, z__1.i = a[i__2].r * + z__2.i + a[i__2].i * z__2.r; + d__1 = z__1.r; + a[i__1].r = d__1, a[i__1].i = 0.; + return; + } + +/* Determine crossover point for when to bail to level2 */ + + nx = ilaenv_(&c__3, "ZLAUUM_RECURSIVE", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)16, ( + ftnlen)1); + if (*n < nx) { + zlauu2_(uplo, n, &a[a_offset], lda, info); + return; + } + +/* Beginning of executable statements for the recursive case */ + + k = *n / 2; + if (upper) { + +/* We are computing A = ut(U*U**H). */ + +/* Break apart U as follows */ +/* |-----------------| */ +/* U = | U_{11} U_{12} | */ +/* | 0 U_{22} | */ +/* |-----------------| */ + +/* Where */ +/* U_{11}\in\C^{k\times k} U_{12}\in\C^{ k\times n-k} */ +/* U_{22}\in\C^{n-k\times n-k} */ + +/* and U_{11},U_{22} are upper triangular and U_{12} is rectangular */ + +/* This gives us our operations as */ +/* |--------------------| |------------------------| */ +/* ut(U * U**H) = | U_{11} U_{12} | | U_{11}**H 0 | */ +/* | 0 U_{22} | | U_{12}**H U_{22}**H | */ +/* |--------------------| |------------------------| */ + +/* Thus we get */ + +/* U_{11} = U_{11}U_{11}**H + U_{12}U_{12}**H */ +/* U_{12} = U_{12}U_{22}**H */ + +/* U_{22} = U_{22}U_{22}**H */ + +/* We break these operations apart as follows */ + +/* U_{11} = U_{11}U_{11}**H (This subroutine) */ +/* U_{11} = U_{12}U_{12}**H + U_{11} (HERK) */ + +/* U_{12} = U_{12}U_{22}**H (TRMM) */ + +/* U_{22} = U_{22}U_{22}**H (This subroutine) */ + + +/* Compute U_{11} */ + + zlauum_recursive_(uplo, &k, &a[a_offset], lda, info); + i__1 = *n - k; + zherk_("Upper", "No Transpose", &k, &i__1, &c_b13, &a[(k + 1) * + a_dim1 + 1], lda, &c_b13, &a[a_offset], lda); + +/* Compute U_{12} */ + + i__1 = *n - k; + ztrmm_("Right", "Upper", "Conjugate", "Non-unit", &k, &i__1, &c_b1, & + a[k + 1 + (k + 1) * a_dim1], lda, &a[(k + 1) * a_dim1 + 1], + lda); + +/* Compute U_{22} */ + + i__1 = *n - k; + zlauum_recursive_(uplo, &i__1, &a[k + 1 + (k + 1) * a_dim1], lda, info); + } else { + +/* We are computing A = lt(L**H*L). */ + +/* Break apart L as follows */ +/* |-----------------| */ +/* L = | L_{11} 0 | */ +/* | L_{21} L_{22} | */ +/* |-----------------| */ + +/* Where */ +/* L_{11}\in\C^{ k\times k} */ +/* L_{21}\in\C^{n-k\times k} l_{22}\in\C^{n-k\times n-k} */ + +/* and L_{11},L_{22} are lower triangular and L_{21} is rectangular */ + +/* This gives us our operations as */ +/* |--------------------------| |-----------------| */ +/* lt(L**H * L) = | L_{11}**H L_{21}**H | | L_{11} 0 | */ +/* | 0 L_{22}**H | | L_{21} L_{22} | */ +/* |--------------------------| |-----------------| */ + +/* Thus we get */ + +/* L_{11} = L_{11}**H L_{11} + L_{21}**H L_{21} */ +/* L_{21} = L_{22}**H L_{21} */ + +/* L_{22} = L_{22}**H L_{22} */ + +/* We break these operations apart as follows */ + +/* L_{11} = L_{11}**H L_{11} (This subroutine) */ +/* L_{11} = L_{21}**H L_{21} + L_{11} (HERK) */ + +/* L_{21} = L_{22}**H L_{21} (TRMM) */ + +/* L_{22} = L_{22}**H L_{22} (This subroutine) */ + + +/* Compute L_{11} */ + + zlauum_recursive_(uplo, &k, &a[a_offset], lda, info); + i__1 = *n - k; + zherk_("Lower", "Conjugate", &k, &i__1, &c_b13, &a[k + 1 + a_dim1], + lda, &c_b13, &a[a_offset], lda); + +/* Compute L_{21} */ + + i__1 = *n - k; + ztrmm_("Left", "Lower", "Conjugate", "Non-Unit", &i__1, &k, &c_b1, &a[ + k + 1 + (k + 1) * a_dim1], lda, &a[k + 1 + a_dim1], lda); + +/* Compute L_{22} */ + + i__1 = *n - k; + zlauum_recursive_(uplo, &i__1, &a[k + 1 + (k + 1) * a_dim1], lda, info); + } + return; +} /* zlauum___ */ + diff --git a/lapack-netlib/SRC/zlauum_recursive.f b/lapack-netlib/SRC/zlauum_recursive.f new file mode 100644 index 0000000000..4a628ca2bd --- /dev/null +++ b/lapack-netlib/SRC/zlauum_recursive.f @@ -0,0 +1,283 @@ +*> \brief \b ZLAUUM_RECURSIVE computes the product UUH or LHL, where U and L are upper or lower triangular matrices (recursive algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZLAUUM_RECURSIVE( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAUUM_RECURSIVE computes the product U * U**H or L**H * L, where the triangular +*> factor U or L is stored in the upper or lower triangular part of +*> the array A. +*> +*> If UPLO = 'U' or 'u' then the upper triangle of the result is stored, +*> overwriting the factor U in A, and the strictly lower triangular part +*> of A is not referenced. +*> If UPLO = 'L' or 'l' then the lower triangle of the result is stored, +*> overwriting the factor L in A, and the strictly upper triangular part +*> of A is not referenced. +*> +*> This is the recursive version of the algorithm +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the triangular factor stored in the array A +*> is upper or lower triangular: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the triangular factor U or L. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the triangular factor U or L. +*> On exit, if UPLO = 'U', the upper triangle of A is +*> overwritten with the upper triangle of the product U * U**H, +*> and the strictly lower triangular part of A is not referenced. +*> If UPLO = 'L', the lower triangle of A is overwritten with +*> the lower triangle of the product L**H * L, and the +*> strictly upper triangular part of A is not referenced. Regardless, +*> the diagonal elements are explicitly set to be real by casting +*. to DBLE before exit. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lauum +* +* ===================================================================== + RECURSIVE SUBROUTINE ZLAUUM_RECURSIVE( UPLO, N, A, LDA, INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZONE + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0, ZONE = (1.0D+0, 0.0D+0) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, NX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLAUU2, ZHERK, ZTRMM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, DCONJG, DBLE +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLAUUM_RECURSIVE', -INFO ) + RETURN + END IF +* +* Early termination criteria +* + IF( N.EQ.0 ) THEN + RETURN + END IF +* +* Base Case +* + IF( N.EQ.1 ) THEN + A(1,1) = DBLE(A(1,1) * DCONJG(A(1,1))) + RETURN + END IF +* +* Determine crossover point for when to bail to level2 +* + NX = ILAENV(3, "ZLAUUM_RECURSIVE", UPLO, N, -1, -1, -1) + IF( N.LT.NX ) THEN + CALL ZLAUU2(UPLO, N, A, LDA, INFO) + RETURN + END IF +* +* Beginning of executable statements for the recursive case +* + K = N/2 + IF( UPPER ) THEN +* +* We are computing A = ut(U*U**H). +* +* Break apart U as follows +* |-----------------| +* U = | U_{11} U_{12} | +* | 0 U_{22} | +* |-----------------| +* +* Where +* U_{11}\in\C^{k\times k} U_{12}\in\C^{ k\times n-k} +* U_{22}\in\C^{n-k\times n-k} +* +* and U_{11},U_{22} are upper triangular and U_{12} is rectangular +* +* This gives us our operations as +* |--------------------| |------------------------| +* ut(U * U**H) = | U_{11} U_{12} | | U_{11}**H 0 | +* | 0 U_{22} | | U_{12}**H U_{22}**H | +* |--------------------| |------------------------| +* +* Thus we get +* +* U_{11} = U_{11}U_{11}**H + U_{12}U_{12}**H +* U_{12} = U_{12}U_{22}**H +* +* U_{22} = U_{22}U_{22}**H +* +* We break these operations apart as follows +* +* U_{11} = U_{11}U_{11}**H (This subroutine) +* U_{11} = U_{12}U_{12}**H + U_{11} (HERK) +* +* U_{12} = U_{12}U_{22}**H (TRMM) +* +* U_{22} = U_{22}U_{22}**H (This subroutine) +* +* +* Compute U_{11} +* + CALL ZLAUUM_RECURSIVE(UPLO, K, A, LDA, INFO) + CALL ZHERK('Upper', 'No Transpose', K, N-K, + $ ONE, A(1,K+1), LDA, ONE, A, LDA) +* +* Compute U_{12} +* + CALL ZTRMM('Right', 'Upper', 'Conjugate', 'Non-unit', + $ K, N-K, ZONE, A(K+1,K+1), LDA, A(1,K+1), LDA) +* +* Compute U_{22} +* + CALL ZLAUUM_RECURSIVE(UPLO, N-K, A(K+1,K+1), LDA, INFO) + ELSE +* +* We are computing A = lt(L**H*L). +* +* Break apart L as follows +* |-----------------| +* L = | L_{11} 0 | +* | L_{21} L_{22} | +* |-----------------| +* +* Where +* L_{11}\in\C^{ k\times k} +* L_{21}\in\C^{n-k\times k} l_{22}\in\C^{n-k\times n-k} +* +* and L_{11},L_{22} are lower triangular and L_{21} is rectangular +* +* This gives us our operations as +* |--------------------------| |-----------------| +* lt(L**H * L) = | L_{11}**H L_{21}**H | | L_{11} 0 | +* | 0 L_{22}**H | | L_{21} L_{22} | +* |--------------------------| |-----------------| +* +* Thus we get +* +* L_{11} = L_{11}**H L_{11} + L_{21}**H L_{21} +* L_{21} = L_{22}**H L_{21} +* +* L_{22} = L_{22}**H L_{22} +* +* We break these operations apart as follows +* +* L_{11} = L_{11}**H L_{11} (This subroutine) +* L_{11} = L_{21}**H L_{21} + L_{11} (HERK) +* +* L_{21} = L_{22}**H L_{21} (TRMM) +* +* L_{22} = L_{22}**H L_{22} (This subroutine) +* +* +* Compute L_{11} +* + CALL ZLAUUM_RECURSIVE(UPLO, K, A, LDA, INFO) + CALL ZHERK('Lower', 'Conjugate', K, N-K, + $ ONE, A(K+1,1), LDA, ONE, A, LDA) +* +* Compute L_{21} +* + CALL ZTRMM('Left', 'Lower', 'Conjugate', 'Non-Unit', + $ N-K, K, ZONE, A(K+1,K+1), LDA, A(K+1,1), LDA) +* +* Compute L_{22} +* + CALL ZLAUUM_RECURSIVE(UPLO, N-K, A(K+1,K+1), LDA, INFO) + END IF + END SUBROUTINE