diff --git a/cmake/lapack.cmake b/cmake/lapack.cmake index 15a87e5e06..42027d5c73 100644 --- a/cmake/lapack.cmake +++ b/cmake/lapack.cmake @@ -137,7 +137,8 @@ set(SLASRC slatrs3.f strsyl3.f sgelst.f sgedmd.f90 sgedmdq.f90 sgecxx.f sbdsvdmr3.f sbdsvdmr3_work.f sgesvdmr3.f sbdtgk.f slar1v_tgk.f slarrf_tgk.f slarrb_tgk.f slarrv_tgk.f slaed0_br.f slaed0_merge_pair.f - slaed4_br.f slaed7_br.f slaed8_br.f slaed9_br.f sstebr.f ssteqr_boundary_br.f) + slaed4_br.f slaed7_br.f slaed8_br.f slaed9_br.f sstebr.f ssteqr_boundary_br.f + slall2.f slallm.f slallm_blocked.f slallm_recursive.f) set(SXLASRC sgesvxx.f sgerfsx.f sla_gerfsx_extended.f sla_geamv.f sla_gercond.f sla_gerpvgrw.f ssysvxx.f ssyrfsx.f @@ -238,7 +239,7 @@ set(CLASRC cgesvdq.f claunhr_col_getrfnp.f claunhr_col_getrfnp2.f cungtsqr.f cungtsqr_row.f cunhr_col.f clatrs3.f ctrsyl3.f cgelst.f cgedmd.f90 cgedmdq.f90 cgecxx.f - cgesvdmr3.f) + cgesvdmr3.f clall2.f clallm.f clallm_blocked.f clallm_recursive.f) set(CXLASRC cgesvxx.f cgerfsx.f cla_gerfsx_extended.f cla_geamv.f cla_gercond_c.f cla_gercond_x.f cla_gerpvgrw.f @@ -334,7 +335,8 @@ set(DLASRC dlatrs3.f dtrsyl3.f dgelst.f dgedmd.f90 dgedmdq.f90 dgecxx.f dbdsvdmr3.f dbdsvdmr3_work.f dgesvdmr3.f dbdtgk.f dlar1v_tgk.f dlarrf_tgk.f dlarrb_tgk.f dlarrv_tgk.f dlaed0_br.f dlaed0_merge_pair.f - dlaed4_br.f dlaed7_br.f dlaed8_br.f dlaed9_br.f dstebr.f dsteqr_boundary_br.f) + dlaed4_br.f dlaed7_br.f dlaed8_br.f dlaed9_br.f dstebr.f dsteqr_boundary_br.f + dlall2.f dlallm.f dlallm_blocked.f dlallm_recursive.f) set(DXLASRC dgesvxx.f dgerfsx.f dla_gerfsx_extended.f dla_geamv.f dla_gercond.f dla_gerpvgrw.f dsysvxx.f dsyrfsx.f @@ -438,7 +440,7 @@ set(ZLASRC zgesvdq.f zlaunhr_col_getrfnp.f zlaunhr_col_getrfnp2.f zungtsqr.f zungtsqr_row.f zunhr_col.f zlatrs3.f ztrsyl3.f zgelst.f zgedmd.f90 zgedmdq.f90 zgecxx.f - zgesvdmr3.f) + zgesvdmr3.f zlall2.f zlallm.f zlallm_blocked.f zlallm_recursive.f) set(ZXLASRC zgesvxx.f zgerfsx.f zla_gerfsx_extended.f zla_geamv.f zla_gercond_c.f zla_gercond_x.f zla_gerpvgrw.f zsysvxx.f zsyrfsx.f @@ -650,7 +652,8 @@ set(SLASRC slatrs3.c strsyl3.c sgelst.c sgedmd.c sgedmdq.c sgecxx.c sbdsvdmr3.c sbdsvdmr3_work.c sgesvdmr3.c sbdtgk.c slar1v_tgk.c slarrf_tgk.c slarrb_tgk.c slarrv_tgk.c slaed0_br.c slaed0_merge_pair.c - slaed4_br.c slaed7_br.c slaed8_br.c slaed9_br.c sstebr.c ssteqr_boundary_br.c) + slaed4_br.c slaed7_br.c slaed8_br.c slaed9_br.c sstebr.c ssteqr_boundary_br.c + slall2.c slallm.c slallm_blocked.c slallm_recursive.c) set(SXLASRC sgesvxx.c sgerfsx.c sla_gerfsx_extended.c sla_geamv.c sla_gercond.c sla_gerpvgrw.c ssysvxx.c ssyrfsx.c @@ -749,7 +752,8 @@ set(CLASRC chbev_2stage.c chbevx_2stage.c chbevd_2stage.c chegv_2stage.c cgesvdq.c claunhr_col_getrfnp.c claunhr_col_getrfnp2.c cungtsqr.c cungtsqr_row.c cunhr_col.c - clatrs3.c ctrsyl3.c cgelst.c cgedmd.c cgedmdq.c cgecxx.c cgesvdmr3.c) + clatrs3.c ctrsyl3.c cgelst.c cgedmd.c cgedmdq.c cgecxx.c cgesvdmr3.c + clall2.c clallm.c clallm_blocked.c clallm_recursive.c) set(CXLASRC cgesvxx.c cgerfsx.c cla_gerfsx_extended.c cla_geamv.c cla_gercond_c.c cla_gercond_x.c cla_gerpvgrw.c @@ -844,7 +848,8 @@ set(DLASRC dlatrs3.c dtrsyl3.c dgelst.c dgedmd.c dgedmdq.c dgecxx.c dbdsvdmr3.c dbdsvdmr3_work.c dgesvdmr3.c dbdtgk.c dlar1v_tgk.c dlarrf_tgk.c dlarrb_tgk.c dlarrv_tgk.c dlaed0_br.c dlaed0_merge_pair.c - dlaed4_br.c dlaed7_br.c dlaed8_br.c dlaed9_br.c dstebr.c dsteqr_boundary_br.c) + dlaed4_br.c dlaed7_br.c dlaed8_br.c dlaed9_br.c dstebr.c dsteqr_boundary_br.c + dlall2.c dlallm.c dlallm_blocked.c dlallm_recursive.c) set(DXLASRC dgesvxx.c dgerfsx.c dla_gerfsx_extended.c dla_geamv.c dla_gercond.c dla_gerpvgrw.c dsysvxx.c dsyrfsx.c @@ -946,7 +951,8 @@ set(ZLASRC zhbev_2stage.c zhbevx_2stage.c zhbevd_2stage.c zhegv_2stage.c zgesvdq.c zlaunhr_col_getrfnp.c zlaunhr_col_getrfnp2.c zungtsqr.c zungtsqr_row.c zunhr_col.c zlatrs3.c ztrsyl3.c zgelst.c - zgedmd.c zgedmdq.c zgecxx.c zgesvdmr3.c) + zgedmd.c zgedmdq.c zgecxx.c zgesvdmr3.c zlall2.c zlallm.c + zlallm_blocked.c zlallm_recursive.c) set(ZXLASRC zgesvxx.c zgerfsx.c zla_gerfsx_extended.c zla_geamv.c zla_gercond_c.c zla_gercond_x.c zla_gerpvgrw.c zsysvxx.c zsyrfsx.c diff --git a/lapack-netlib/SRC/Makefile b/lapack-netlib/SRC/Makefile index 96289d6383..063ab57237 100644 --- a/lapack-netlib/SRC/Makefile +++ b/lapack-netlib/SRC/Makefile @@ -236,7 +236,8 @@ SLASRC_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 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 + slaed4_br.o slaed7_br.o slaed8_br.o slaed9_br.o sstebr.o ssteqr_boundary_br.o \ + slall2.o slallm.o slallm_blocked.o slallm_recursive.o endif ifneq "$(or $(BUILD_SINGLE),$(BUILD_DOUBLE))" "" @@ -346,7 +347,7 @@ CLASRC_O = \ cheevd_2stage.o cheev_2stage.o cheevx_2stage.o cheevr_2stage.o \ chbev_2stage.o chbevx_2stage.o chbevd_2stage.o chegv_2stage.o \ cgesvdq.o clatrs3.o ctrsyl3.o cgelst.o cgedmd.o cgedmdq.o cgecxx.o \ - cgesvdmr3.o + cgesvdmr3.o clall2.o clallm.o clallm_blocked.o clallm_recursive.o endif ifdef USEXBLAS @@ -450,7 +451,8 @@ DLASRC_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 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 + dlaed4_br.o dlaed7_br.o dlaed8_br.o dlaed9_br.o dstebr.o dsteqr_boundary_br.o \ + dlall2.o dlallm.o dlallm_blocked.o dlallm_recursive.o endif ifdef USEXBLAS @@ -560,7 +562,7 @@ ZLASRC_O = \ zheevd_2stage.o zheev_2stage.o zheevx_2stage.o zheevr_2stage.o \ zhbev_2stage.o zhbevx_2stage.o zhbevd_2stage.o zhegv_2stage.o \ zgesvdq.o zlatrs3.o ztrsyl3.o zgelst.o zgedmd.o zgedmdq.o zgecxx.o \ - zgesvdmr3.o + zgesvdmr3.o zlall2.o zlallm.o zlallm_blocked.o zlallm_recursive.o endif ifdef USEXBLAS diff --git a/lapack-netlib/SRC/clall2.c b/lapack-netlib/SRC/clall2.c new file mode 100644 index 0000000000..cc8b301037 --- /dev/null +++ b/lapack-netlib/SRC/clall2.c @@ -0,0 +1,465 @@ +#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 _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +#endif +#define pCf(z) (*_pCf(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);} +#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)} + +/* Table of constant values */ + +static complex c_b1 = {1.f,0.f}; +static integer c__1 = 1; + +/* > \brief \b CLALL2 computes the product LLH or UHU, where U and L are upper or lower triangular matrices (u +nblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLALL2( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLALL2 computes the product L * L**H or U**H * U, 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 unblocked form 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**h * U, */ +/* > 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 * L**H, 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 lall2 */ + +/* ===================================================================== */ +/* Subroutine */ void clall2_(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; + + /* Local variables */ + 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 *); + logical upper; + extern /* Subroutine */ void xerbla_(char *, integer *, 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_("CLALL2", &i__1, (ftnlen)6); + return; + } + +/* Quick return if possible */ + + if (*n == 0) { + return; + } + if (upper) { + +/* Compute and store ut(U**H U) */ + + for (j = *n; j >= 1; --j) { + +/* Complex will want to store the conjugate */ + + r_cnjg(&q__1, &a[j + j * a_dim1]); + ajj.r = q__1.r, ajj.i = q__1.i; + if (j == 1) { + cscal_(n, &ajj, &a[a_offset], lda); + } else { + +/* complex version will need {c,z}gemm since the vector x is */ +/* conjugated (or a {c,z}gemcv-like statement) */ + + i__1 = *n - j + 1; + i__2 = j - 1; + cgemm_("Conjugate Transpose", "No Transpose", &c__1, &i__1, & + i__2, &c_b1, &a[j * a_dim1 + 1], lda, &a[j * a_dim1 + + 1], lda, &ajj, &a[j + j * a_dim1], lda); + } + i__1 = j + j * a_dim1; + i__2 = j + j * a_dim1; + r__1 = a[i__2].r; + a[i__1].r = r__1, a[i__1].i = 0.f; + } + } else { + +/* Compute and store lt(LL**H) */ + + for (i__ = *n; i__ >= 1; --i__) { + +/* Complex will want to store the conjugate */ + + r_cnjg(&q__1, &a[i__ + i__ * a_dim1]); + aii.r = q__1.r, aii.i = q__1.i; + if (i__ == 1) { + cscal_(n, &aii, &a[a_offset], &c__1); + } else { + +/* complex version will need {c,z}gemm since the vector x is */ +/* conjugated (or a {c,z}gemcv-like statement) */ + + i__1 = *n - i__ + 1; + i__2 = i__ - 1; + cgemm_("No Transpose", "Conjugate Transpose", &i__1, &c__1, & + i__2, &c_b1, &a[i__ + a_dim1], lda, &a[i__ + a_dim1], + lda, &aii, &a[i__ + i__ * a_dim1], lda); + } + i__1 = i__ + i__ * a_dim1; + i__2 = i__ + i__ * a_dim1; + r__1 = a[i__2].r; + a[i__1].r = r__1, a[i__1].i = 0.f; + } + } + return; +} /* clall2_ */ + diff --git a/lapack-netlib/SRC/clall2.f b/lapack-netlib/SRC/clall2.f new file mode 100644 index 0000000000..589d9b00b4 --- /dev/null +++ b/lapack-netlib/SRC/clall2.f @@ -0,0 +1,200 @@ +*> \brief \b CLALL2 computes the product LLH or UHU, where U and L are upper or lower triangular matrices (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CLALL2( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLALL2 computes the product L * L**H or U**H * U, 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 unblocked form 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**h * U, +*> 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 * L**H, 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 lall2 +* +* ===================================================================== + SUBROUTINE CLALL2( 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 ONE + PARAMETER ( ONE = (1.0E+0,0.0E+0) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I,J + COMPLEX AII,AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CSCAL, CGEMM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, CONJG +* .. +* .. 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( 'CLALL2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + IF( UPPER ) THEN +* +* Compute and store ut(U**H U) +* + DO J = N, 1, -1 +* +* Complex will want to store the conjugate +* + AJJ = CONJG(A(J,J)) + IF( J.EQ.1 ) THEN + CALL CSCAL(N, AJJ, A, LDA) + ELSE +* +* complex version will need {c,z}gemm since the vector x is +* conjugated (or a {c,z}gemcv-like statement) +* + CALL CGEMM('Conjugate Transpose', 'No Transpose', + $ 1, N-J+1, J-1, ONE, A(1,J), LDA, A(1,J), LDA, + $ AJJ, A(J,J), LDA) + END IF + A(J,J) = REAL(A(J,J)) + END DO + ELSE +* +* Compute and store lt(LL**H) +* + DO I = N, 1, -1 +* +* Complex will want to store the conjugate +* + AII = CONJG(A(I,I)) + IF( I.EQ.1 ) THEN + CALL CSCAL(N, AII, A, 1) + ELSE +* +* complex version will need {c,z}gemm since the vector x is +* conjugated (or a {c,z}gemcv-like statement) +* + CALL CGEMM('No Transpose', 'Conjugate Transpose', + $ N-I+1, 1, I-1, ONE, A(I,1), LDA, A(I,1), LDA, + $ AII, A(I,I), LDA) + END IF + A(I,I) = REAL(A(I,I)) + END DO + END IF + END SUBROUTINE diff --git a/lapack-netlib/SRC/clallm.c b/lapack-netlib/SRC/clallm.c new file mode 100644 index 0000000000..f894795fee --- /dev/null +++ b/lapack-netlib/SRC/clallm.c @@ -0,0 +1,406 @@ +#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 _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +#endif +#define pCf(z) (*_pCf(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);} +#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)} + +/* > \brief \b CLALLM computes the product LLH or UHU, 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/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLALLM( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLALLM computes the product L * L**H or U**H * U, 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. Regardless, the diagonal elements are explicitly */ +/* > set to be real by casting to REAL before exit. */ +/* > This is the driver that idpatches to either blocked or recursive */ +/* > \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**H * U, */ +/* > 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 * L**H, 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 lallm */ + +/* ===================================================================== */ +/* Subroutine */ void clallm_(char *uplo, integer *n, complex *a, integer *lda, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), clallm_recursive_( + char *, integer *, complex *, 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..-- */ + + +/* ===================================================================== */ + +/* 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_("CLALLM", &i__1, (ftnlen)6); + return; + } + +/* Quick return if possible */ + + if (*n == 0) { + return; + } + +/* 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...` */ + + clallm_recursive_(uplo, n, &a[a_offset], lda, info); + //clallm_blocked(uplo, n, &a[a_offset], lda, info); + return; + +/* End of CLAUUM */ + +} /* clallm_ */ + diff --git a/lapack-netlib/SRC/clallm.f b/lapack-netlib/SRC/clallm.f new file mode 100644 index 0000000000..03b91d9ca9 --- /dev/null +++ b/lapack-netlib/SRC/clallm.f @@ -0,0 +1,162 @@ +*> \brief \b CLALLM computes the product LLH or UHU, 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/ +* +* Definition: +* =========== +* +* SUBROUTINE CLALLM( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLALLM computes the product L * L**H or U**H * U, 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. Regardless, the diagonal elements are explicitly +*> set to be real by casting to REAL before exit. +*> This is the driver that idpatches to either blocked or recursive +*> \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**H * U, +*> 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 * L**H, 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 lallm +* +* ===================================================================== + SUBROUTINE CLALLM( 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, * ) +* .. +* +* ===================================================================== +* .. +* .. Local Scalars .. + LOGICAL UPPER +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CLALLM_BLOCKED, + $ CLALLM_RECURSIVE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. 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( 'CLALLM', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* 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 CLALLM_RECURSIVE(UPLO, N, A, LDA, INFO) +* CALL CLALLM_BLOCKED(UPLO, N, A, LDA, INFO) + RETURN +* +* End of CLAUUM +* + END SUBROUTINE diff --git a/lapack-netlib/SRC/clallm_blocked.c b/lapack-netlib/SRC/clallm_blocked.c new file mode 100644 index 0000000000..e4de3754b0 --- /dev/null +++ b/lapack-netlib/SRC/clallm_blocked.c @@ -0,0 +1,531 @@ +#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 _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +#endif +#define pCf(z) (*_pCf(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);} +#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)} + +/* 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_b20 = 1.f; + +/* > \brief \b CLALLM_BLOCKED computes the product LLH or UHU, 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 CLALLM_BLOCKED( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLALLM computes the product L * L**H or U**H * U, 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. Regardless, the diagonal of A is explicitly */ +/* > set to real by casting to REAL before exit. */ +/* > */ +/* > 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**H * U, */ +/* > 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 * L**H, and the strictly */ +/* > upper triangular part of A is not referenced. Regardless, */ +/* > the diagonal of A is 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 lallm */ + +/* ===================================================================== */ +/* Subroutine */ void clallm_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; + + /* Local variables */ + integer i__, k, ib, nb, ki; + 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 clall2_(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_("CLALLM_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, "CLALLM_BLOCKED", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)14, (ftnlen)1); + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + clall2_(uplo, n, &a[a_offset], lda, info); + return; + } + +/* Determine the size of the last block */ + + k = *n / nb; + +/* The last block starts at KI */ + + ki = nb * k + 1; + +/* IB will hold the size of the block we are currently interested in */ + + ib = *n - ki + 1; + if (upper) { + +/* We go bottom to top computing one row at a time */ + + i__1 = -nb; + for (i__ = ki; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { + +/* If not the first iteration */ + + if (i__ + ib <= *n) { + +/* Use the current diagonal block to update the right of it */ +/* We guard this to prevent potentially referencing invalid memory */ + + i__2 = *n - (i__ + ib) + 1; + ctrmm_("Left", "Upper", "Conjguate", "Non-Unit", &ib, &i__2, & + c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__ + (i__ + ib) + * a_dim1], lda); + +/* Update the right of the current diagonal block with the */ +/* part of A above the current diagonal block */ +/* We don't do this on the last (first in the array) */ +/* However since we will not be accessing invalid */ +/* memory and cgemm promises to do nothing when */ +/* any input dimension is 0, we don't have to guard here */ + + i__2 = *n - (i__ + ib) + 1; + i__3 = i__ - 1; + cgemm_("Conjguate", "No Transpose", &ib, &i__2, &i__3, &c_b1, + &a[i__ * a_dim1 + 1], lda, &a[(i__ + ib) * a_dim1 + 1] + , lda, &c_b1, &a[i__ + (i__ + ib) * a_dim1], lda); + } + +/* Now, we update the diagonal block of interest */ + + clall2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); + +/* Update the diagonal block with the part of A above the diagonal */ + + i__2 = i__ - 1; + cherk_("Upper", "Conjguate", &ib, &i__2, &c_b20, &a[i__ * a_dim1 + + 1], lda, &c_b20, &a[i__ + i__ * a_dim1], lda); + +/* Only the first iteration will have IB be different from NB */ + + ib = nb; + } + } else { + i__1 = -nb; + for (i__ = ki; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { + +/* If not the first iteration */ + + if (i__ + ib <= *n) { + +/* Use the current diagonal block to update belowit */ +/* We guard this to prevent potentially referencing invalid memory */ + + i__2 = *n - (i__ + ib) + 1; + ctrmm_("Right", "Lower", "Conjguate", "Non-Unit", &i__2, &ib, + &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__ + ib + i__ + * a_dim1], lda); + +/* Update the right of the current diagonal block with the */ +/* part of A above the current diagonal block */ +/* We don't do this on the last (first in the array) */ +/* However since we will not be accessing invalid */ +/* memory and cgemm promises to do nothing when */ +/* any input dimension is 0, we don't have to guard here */ + + i__2 = *n - (i__ + ib) + 1; + i__3 = i__ - 1; + cgemm_("No Transpose", "Conjguate", &i__2, &ib, &i__3, &c_b1, + &a[i__ + ib + a_dim1], lda, &a[i__ + a_dim1], lda, & + c_b1, &a[i__ + ib + i__ * a_dim1], lda); + } + +/* Now, we update the diagonal block of interest */ + + clall2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); + +/* Update the diagonal block with the part of A above the diagonal */ + + i__2 = i__ - 1; + cherk_("Lower", "No Transpose", &ib, &i__2, &c_b20, &a[i__ + + a_dim1], lda, &c_b20, &a[i__ + i__ * a_dim1], lda); + +/* Only the first iteration will have IB be different from NB */ + + ib = nb; + } + } + return; +} /* clallm_blocked__ */ + diff --git a/lapack-netlib/SRC/clallm_blocked.f b/lapack-netlib/SRC/clallm_blocked.f new file mode 100644 index 0000000000..58afbdff9d --- /dev/null +++ b/lapack-netlib/SRC/clallm_blocked.f @@ -0,0 +1,262 @@ +*> \brief \b CLALLM_BLOCKED computes the product LLH or UHU, 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 CLALLM_BLOCKED( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLALLM computes the product L * L**H or U**H * U, 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. Regardless, the diagonal of A is explicitly +*> set to real by casting to REAL before exit. +*> +*> 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**H * U, +*> 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 * L**H, and the strictly +*> upper triangular part of A is not referenced. Regardless, +*> the diagonal of A is 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 lallm +* +* ===================================================================== + SUBROUTINE CLALLM_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 + COMPLEX CONE + PARAMETER ( ONE = 1.0E+0, CONE = (1.0E+0, 0.0E+0) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IB, NB, K, KI +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CLALL2, CTRMM, CGEMM, CHERK +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. 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( 'DLALLM', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'CLALLM_BLOCKED', UPLO, N, -1, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL CLALL2( UPLO, N, A, LDA, INFO ) + RETURN + END IF +* +* Determine the size of the last block +* + K = N / NB +* +* The last block starts at KI +* + KI = NB*K + 1 +* +* IB will hold the size of the block we are currently interested in +* + IB = N - KI + 1 + IF( UPPER ) THEN +* +* We go bottom to top computing one row at a time +* + DO I = KI, 1, -NB +* +* If not the first iteration +* + IF( I+IB.LE.N ) THEN +* +* Use the current diagonal block to update the right of it +* We guard this to prevent potentially referencing invalid memory +* + CALL CTRMM('Left', 'Upper', 'Conjguate', 'Non-Unit', + $ IB, N-(I+IB)+1, CONE, A(I,I), LDA, A(I,I+IB), LDA) +* +* Update the right of the current diagonal block with the +* part of A above the current diagonal block +* We don't do this on the last (first in the array) +* However since we will not be accessing invalid +* memory and cgemm promises to do nothing when +* any input dimension is 0, we don't have to guard here +* + CALL CGEMM('Conjguate', 'No Transpose', + $ IB, N-(I+IB)+1, I-1, + $ CONE, A(1,I), LDA, A(1,I+IB), LDA, + $ CONE, A(I,I+IB), LDA) + END IF +* +* Now, we update the diagonal block of interest +* + CALL CLALL2('Upper', IB, A(I,I), LDA, INFO) +* +* Update the diagonal block with the part of A above the diagonal +* + CALL CHERK('Upper', 'Conjguate', IB, I-1, + $ ONE, A(1,I), LDA, ONE, A(I,I), LDA) +* +* Only the first iteration will have IB be different from NB +* + IB = NB + END DO + ELSE + DO I = KI, 1, -NB +* +* If not the first iteration +* + IF( I+IB.LE.N ) THEN +* +* Use the current diagonal block to update belowit +* We guard this to prevent potentially referencing invalid memory +* + CALL CTRMM('Right', 'Lower', 'Conjguate', 'Non-Unit', + $ N-(I+IB)+1, IB, CONE, A(I,I), LDA, A(I+IB,I), LDA) +* +* Update the right of the current diagonal block with the +* part of A above the current diagonal block +* We don't do this on the last (first in the array) +* However since we will not be accessing invalid +* memory and cgemm promises to do nothing when +* any input dimension is 0, we don't have to guard here +* + CALL CGEMM('No Transpose', 'Conjguate', + $ N-(I+IB)+1, IB, I-1, + $ CONE, A(I+IB,1), LDA, A(I,1), LDA, + $ CONE, A(I+IB,I), LDA) + END IF +* +* Now, we update the diagonal block of interest +* + CALL CLALL2('Lower', IB, A(I,I), LDA, INFO) +* +* Update the diagonal block with the part of A above the diagonal +* + CALL CHERK('Lower', 'No Transpose', IB, I-1, + $ ONE, A(I,1), LDA, ONE, A(I,I), LDA) +* +* Only the first iteration will have IB be different from NB +* + IB = NB + END DO + END IF + END SUBROUTINE diff --git a/lapack-netlib/SRC/clallm_recursive.c b/lapack-netlib/SRC/clallm_recursive.c new file mode 100644 index 0000000000..05ecefcece --- /dev/null +++ b/lapack-netlib/SRC/clallm_recursive.c @@ -0,0 +1,549 @@ +#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 _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +#endif +#define pCf(z) (*_pCf(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);} +#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)} + +/* Table of constant values */ + +static complex c_b1 = {1.f,0.f}; +static integer c__3 = 3; +static integer c_n1 = -1; +static real c_b13 = 1.f; + +/* > \brief \b CLALLM_ computes the product LLH or UHU, 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 CLALLM_( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLALLM_ computes the product L * L**H or U**H * U, 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. Regardless, the diagonal elements are explicitly */ +/* > set to be real by casting to REAL before exit. */ +/* > */ +/* > This is the recursive form 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**H * U, */ +/* > 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 * L**H, 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 lallm */ + +/* ===================================================================== */ +/* Subroutine */ void clallm_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 clall2_(char *, integer *, complex *, integer + *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + + +/* ===================================================================== */ + + +/* 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_("CLALLM_RECURSIVE", &i__1, (ftnlen)17); + 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, "CLALLM_RECURSIVE", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)17, ( + ftnlen)1); + if (*n <= nx) { + clall2_(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**H U) */ + +/* Break apart U as */ + +/* |-----------------| */ +/* 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} and U_{22} are upper triangular and U_{12} is rectangular */ + +/* This gives us our operations as */ +/* |--------------------------| |-----------------| */ +/* ut(U**H U) = | U_{11}**H 0 | | U_{11} U_{12} | */ +/* | U_{12}**H U_{22}**H | | 0 U_{22} | */ +/* |--------------------------| |-----------------| */ + +/* Thus we get */ + +/* U_{11} = U_{11}**H U_{11} */ +/* U_{12} = U_{11}**H U_{12} */ + +/* U_{22} = U_{12}**H U_{12} + U_{22}**H U_{22} */ + +/* We break these operations apart as follows */ + +/* U_{22} = U_{22}**H U_{22} (This subroutine) */ +/* U_{22} = U_{12}**H U_{12} + U_{22} (HERK) */ + +/* U_{12} = U_{11}**H U_{12} (TRMM) */ + +/* U_{11} = U_{11}**H U_{11} (This subroutine) */ + +/* Compute U_{22} */ + + i__1 = *n - k; + clallm_recursive_(uplo, &i__1, &a[k + 1 + (k + 1) * a_dim1], lda, info); + i__1 = *n - k; + cherk_("Upper", "Conjugate Transpose", &i__1, &k, &c_b13, &a[(k + 1) * + a_dim1 + 1], lda, &c_b13, &a[k + 1 + (k + 1) * a_dim1], lda); + +/* Compute U_{12} */ + + i__1 = *n - k; + ctrmm_("Left", "Upper", "Conjugate", "Non-unit", &k, &i__1, &c_b1, &a[ + a_offset], lda, &a[(k + 1) * a_dim1 + 1], lda); + +/* Compute U_{11} */ + + clallm_recursive_(uplo, &k, &a[a_offset], lda, info); + } else { + +/* We are computing A = lt(LL**H) */ + +/* Break apart L as */ + +/* |-----------------| */ +/* 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} and L_{22} are lower triangular and L_{21} is rectangular */ + +/* This gives us our operations as */ +/* |--------------------| |-----------------------| */ +/* lt(LL**H) = | L_{11} 0 | | L_{11}**H L_{21}**H | */ +/* | L_{21} L_{22} | | 0 L_{22}**H | */ +/* |--------------------| |-----------------------| */ + +/* Thus we get */ + +/* L_{11} = L_{11} L_{11}**H */ +/* L_{21} = L_{21} L_{11}**H */ + +/* L_{22} = L_{21} L_{21}**H + L_{22} L_{22}**H */ + +/* We break these operations apart as follows */ + +/* L_{22} = L_{22} L_{22}**H (This subroutine) */ +/* L_{22} = L_{21} L_{21}**H + L_{22} (HERK) */ + +/* L_{21} = L_{21} L_{11}**H (TRMM) */ + +/* L_{11} = L_{11} L_{11}**H (This subroutine) */ + +/* Compute L_{22} */ + + i__1 = *n - k; + clallm_recursive_(uplo, &i__1, &a[k + 1 + (k + 1) * a_dim1], lda, info); + i__1 = *n - k; + cherk_("Lower", "No Transpose", &i__1, &k, &c_b13, &a[k + 1 + a_dim1], + lda, &c_b13, &a[k + 1 + (k + 1) * a_dim1], lda); + +/* Compute L_{21} */ + + i__1 = *n - k; + ctrmm_("Right", "Lower", "Conjugate", "Non-unit", &i__1, &k, &c_b1, & + a[a_offset], lda, &a[k + 1 + a_dim1], lda); + +/* Compute L_{11} */ + + clallm_recursive_(uplo, &k, &a[a_offset], lda, info); + } + return; +} /* clallm___ */ + diff --git a/lapack-netlib/SRC/clallm_recursive.f b/lapack-netlib/SRC/clallm_recursive.f new file mode 100644 index 0000000000..78ab5df300 --- /dev/null +++ b/lapack-netlib/SRC/clallm_recursive.f @@ -0,0 +1,282 @@ +*> \brief \b CLALLM_RECURSIVE computes the product LLH or UHU, 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 CLALLM_RECURSIVE( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLALLM_RECURSIVE computes the product L * L**H or U**H * U, 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. Regardless, the diagonal elements are explicitly +*> set to be real by casting to REAL before exit. +*> +*> This is the recursive form 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**H * U, +*> 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 * L**H, 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 lallm +* +* ===================================================================== + RECURSIVE SUBROUTINE CLALLM_RECURSIVE( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ) +* .. +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX CONE + REAL ONE + PARAMETER ( CONE = (1.0E+0,0.0E+0), ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I,J,NX,K + COMPLEX AII,AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CLALL2, CHERK, CTRMM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. 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( 'CLALLM_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, "CLALLM_RECURSIVE", UPLO, N, -1, -1, -1) + IF( N.LE.NX ) THEN + CALL CLALL2(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**H U) +* +* Break apart U as +* +* |-----------------| +* 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} and U_{22} are upper triangular and U_{12} is rectangular +* +* This gives us our operations as +* |--------------------------| |-----------------| +* ut(U**H U) = | U_{11}**H 0 | | U_{11} U_{12} | +* | U_{12}**H U_{22}**H | | 0 U_{22} | +* |--------------------------| |-----------------| +* +* Thus we get +* +* U_{11} = U_{11}**H U_{11} +* U_{12} = U_{11}**H U_{12} +* +* U_{22} = U_{12}**H U_{12} + U_{22}**H U_{22} +* +* We break these operations apart as follows +* +* U_{22} = U_{22}**H U_{22} (This subroutine) +* U_{22} = U_{12}**H U_{12} + U_{22} (HERK) +* +* U_{12} = U_{11}**H U_{12} (TRMM) +* +* U_{11} = U_{11}**H U_{11} (This subroutine) +* +* Compute U_{22} +* + CALL CLALLM_RECURSIVE(UPLO, N-K, A(K+1,K+1), LDA, INFO) + CALL CHERK('Upper', 'Conjugate Transpose', N-K, K, + $ ONE, A(1,K+1), LDA, ONE, A(K+1,K+1), LDA) +* +* Compute U_{12} +* + CALL CTRMM('Left', 'Upper', 'Conjugate', 'Non-unit', + $ K, N-K, CONE, A, LDA, A(1,K+1), LDA) +* +* Compute U_{11} +* + CALL CLALLM_RECURSIVE(UPLO, K, A, LDA, INFO) + ELSE +* +* We are computing A = lt(LL**H) +* +* Break apart L as +* +* |-----------------| +* 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} and L_{22} are lower triangular and L_{21} is rectangular +* +* This gives us our operations as +* |--------------------| |-----------------------| +* lt(LL**H) = | L_{11} 0 | | L_{11}**H L_{21}**H | +* | L_{21} L_{22} | | 0 L_{22}**H | +* |--------------------| |-----------------------| +* +* Thus we get +* +* L_{11} = L_{11} L_{11}**H +* L_{21} = L_{21} L_{11}**H +* +* L_{22} = L_{21} L_{21}**H + L_{22} L_{22}**H +* +* We break these operations apart as follows +* +* L_{22} = L_{22} L_{22}**H (This subroutine) +* L_{22} = L_{21} L_{21}**H + L_{22} (HERK) +* +* L_{21} = L_{21} L_{11}**H (TRMM) +* +* L_{11} = L_{11} L_{11}**H (This subroutine) +* +* Compute L_{22} +* + CALL CLALLM_RECURSIVE(UPLO, N-K, A(K+1,K+1), LDA, INFO) + CALL CHERK('Lower', 'No Transpose', N-K, K, + $ ONE, A(K+1,1), LDA, ONE, A(K+1,K+1), LDA) +* +* Compute L_{21} +* + CALL CTRMM('Right', 'Lower', 'Conjugate', 'Non-unit', + $ N-K, K, CONE, A, LDA, A(K+1,1), LDA) +* +* Compute L_{11} +* + CALL CLALLM_RECURSIVE(UPLO, K, A, LDA, INFO) + END IF + + END SUBROUTINE diff --git a/lapack-netlib/SRC/dlall2.c b/lapack-netlib/SRC/dlall2.c new file mode 100644 index 0000000000..79df25b893 --- /dev/null +++ b/lapack-netlib/SRC/dlall2.c @@ -0,0 +1,423 @@ +#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)} + +/* Table of constant values */ + +static doublereal c_b6 = 1.; +static integer c__1 = 1; + +/* > \brief \b DLALL2 computes the product LLT or UTU, where U and L are upper or lower triangular matrices (u +nblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLALL2( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* DOUBLE PRECISION A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLALL2 computes the product L * L**T or U**T * U, 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 unblocked form 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**h * U, */ +/* > 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 * L**T, 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 lall2 */ + +/* ===================================================================== */ +/* Subroutine */ void dlall2_(char *uplo, integer *n, doublereal *a, integer * + lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + doublereal aii, ajj; + extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ void dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + logical upper; + extern /* Subroutine */ void xerbla_(char *, integer *, 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_("DLALL2", &i__1, (ftnlen)6); + return; + } + +/* Quick return if possible */ + + if (*n == 0) { + return; + } + if (upper) { + +/* Compute and store ut(U**T U) */ + + for (j = *n; j >= 1; --j) { + +/* Complex will want to store the conjugate */ + + ajj = a[j + j * a_dim1]; + if (j == 1) { + dscal_(n, &ajj, &a[a_offset], lda); + } else { + +/* complex version will need {c,z}gemm since the vector x is */ +/* conjugated (or a {c,z}gemcv-like statement) */ + + i__1 = j - 1; + i__2 = *n - j + 1; + dgemv_("Transpose", &i__1, &i__2, &c_b6, &a[j * a_dim1 + 1], + lda, &a[j * a_dim1 + 1], &c__1, &ajj, &a[j + j * + a_dim1], lda); + } + } + } else { + +/* Compute and store lt(LL**T) */ + + for (i__ = *n; i__ >= 1; --i__) { + +/* Complex will want to store the conjugate */ + + aii = a[i__ + i__ * a_dim1]; + if (i__ == 1) { + dscal_(n, &aii, &a[a_offset], &c__1); + } else { + +/* complex version will need {c,z}gemm since the vector x is */ +/* conjugated (or a {c,z}gemcv-like statement) */ + + i__1 = *n - i__ + 1; + i__2 = i__ - 1; + dgemv_("No Transpose", &i__1, &i__2, &c_b6, &a[i__ + a_dim1], + lda, &a[i__ + a_dim1], lda, &aii, &a[i__ + i__ * + a_dim1], &c__1); + } + } + } + return; +} /* dlall2_ */ + diff --git a/lapack-netlib/SRC/dlall2.f b/lapack-netlib/SRC/dlall2.f new file mode 100644 index 0000000000..584ca8f6e4 --- /dev/null +++ b/lapack-netlib/SRC/dlall2.f @@ -0,0 +1,194 @@ +*> \brief \b DLALL2 computes the product LLT or UTU, where U and L are upper or lower triangular matrices (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DLALL2( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLALL2 computes the product L * L**T or U**T * U, 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 unblocked form 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**h * U, +*> 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 * L**T, 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 lall2 +* +* ===================================================================== + SUBROUTINE DLALL2( 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,J + DOUBLE PRECISION AII,AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DSCAL, DGEMV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. 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( 'DLALL2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + IF( UPPER ) THEN +* +* Compute and store ut(U**T U) +* + DO J = N, 1, -1 +* +* Complex will want to store the conjugate +* + AJJ = A(J,J) + IF( J.EQ.1 ) THEN + CALL DSCAL(N, AJJ, A, LDA) + ELSE +* +* complex version will need {c,z}gemm since the vector x is +* conjugated (or a {c,z}gemcv-like statement) +* + CALL DGEMV('Transpose', J-1, N-J+1, ONE, + $ A(1,J), LDA, A(1,J), 1, AJJ, A(J,J), LDA) + END IF + END DO + ELSE +* +* Compute and store lt(LL**T) +* + DO I = N, 1, -1 +* +* Complex will want to store the conjugate +* + AII = A(I,I) + IF( I.EQ.1 ) THEN + CALL DSCAL(N, AII, A, 1) + ELSE +* +* complex version will need {c,z}gemm since the vector x is +* conjugated (or a {c,z}gemcv-like statement) +* + CALL DGEMV('No Transpose', N-I+1, I-1, ONE, + $ A(I,1), LDA, A(I,1), LDA, AII, A(I,I), 1) + END IF + END DO + END IF + END SUBROUTINE diff --git a/lapack-netlib/SRC/dlallm.c b/lapack-netlib/SRC/dlallm.c new file mode 100644 index 0000000000..268ebd3ca6 --- /dev/null +++ b/lapack-netlib/SRC/dlallm.c @@ -0,0 +1,378 @@ +#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)} + +/* Table of constant values */ + +static integer c__1 = 1; + +/* > \brief \b DLALLM computes the product LLH or UHU, 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/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLALLM( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* DOUBLE PRECISION A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLALLM computes the product L * L**H or U**H * U, 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 driver that idpatches to either blocked or recursive */ +/* > \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**h * U, */ +/* > 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 * L**H, 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 lallm */ + +/* ===================================================================== */ +/* Subroutine */ void dlallm_(char *uplo, integer *n, doublereal *a, integer * + lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), dlallm_recursive_( + char *, integer *, doublereal *, 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..-- */ + + +/* ===================================================================== */ + +/* 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_("DLALLM", &i__1, (ftnlen)6); + return; + } + +/* Quick return if possible */ + + if (*n == 0) { + return; + } + +/* 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...` */ + + dlallm_recursive_(uplo, n, &a[a_offset], lda, info); + //dlallm_blocked_(uplo, n, &a[a_offset], lda, info); + return; + +/* End of DLAUUM */ + +} /* dlallm_ */ + diff --git a/lapack-netlib/SRC/dlallm.f b/lapack-netlib/SRC/dlallm.f new file mode 100644 index 0000000000..9f6a348cf9 --- /dev/null +++ b/lapack-netlib/SRC/dlallm.f @@ -0,0 +1,159 @@ +*> \brief \b DLALLM computes the product LLH or UHU, 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/ +* +* Definition: +* =========== +* +* SUBROUTINE DLALLM( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLALLM computes the product L * L**H or U**H * U, 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 driver that idpatches to either blocked or recursive +*> \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**h * U, +*> 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 * L**H, 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 lallm +* +* ===================================================================== + SUBROUTINE DLALLM( 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, * ) +* .. +* +* ===================================================================== +* .. +* .. Local Scalars .. + LOGICAL UPPER +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLALLM_BLOCKED, + $ DLALLM_RECURSIVE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. 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( 'DLALLM', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* 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 DLALLM_RECURSIVE(UPLO, N, A, LDA, INFO) +* CALL DLALLM_BLOCKED(UPLO, N, A, LDA, INFO) + RETURN +* +* End of DLAUUM +* + END SUBROUTINE diff --git a/lapack-netlib/SRC/dlallm_blocked.c b/lapack-netlib/SRC/dlallm_blocked.c new file mode 100644 index 0000000000..0fc228749c --- /dev/null +++ b/lapack-netlib/SRC/dlallm_blocked.c @@ -0,0 +1,499 @@ +#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)} + +/* Table of constant values */ + +static integer c__1 = 1; +static integer c_n1 = -1; +static doublereal c_b14 = 1.; + +/* > \brief \b DLALLM_BLOCKED computes the product LLH or UHU, 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 DLALLM_BLOCKED( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* DOUBLE PRECISION A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLALLM_BLOCKED computes the product L * L**T or U**T * U, 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**T * U, */ +/* > 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 * L**T, 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 lallm */ + +/* ===================================================================== */ +/* Subroutine */ void dlallm_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; + + /* Local variables */ + integer i__, k, ib, nb, ki; + 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 *), dlall2_(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_("DLALLM_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, "DLALLM_BLOCKED", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)14, (ftnlen)1); + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + dlall2_(uplo, n, &a[a_offset], lda, info); + return; + } + +/* Determine the size of the last block */ + + k = *n / nb; + +/* The last block starts at KI */ + + ki = nb * k + 1; + +/* IB will hold the size of the block we are currently interested in */ + + ib = *n - ki + 1; + if (upper) { + +/* We go bottom to top computing one row at a time */ + + i__1 = -nb; + for (i__ = ki; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { + +/* If not the first iteration */ + + if (i__ + ib <= *n) { + +/* Use the current diagonal block to update the right of it */ +/* We guard this to prevent potentially referencing invalid memory */ + + i__2 = *n - (i__ + ib) + 1; + dtrmm_("Left", "Upper", "Transpose", "Non-Unit", &ib, &i__2, & + c_b14, &a[i__ + i__ * a_dim1], lda, &a[i__ + (i__ + + ib) * a_dim1], lda); + +/* Update the right of the current diagonal block with the */ +/* part of A above the current diagonal block */ +/* We don't do this on the last (first in the array) */ +/* However since we will not be accessing invalid */ +/* memory and dgemm promises to do nothing when */ +/* any input dimension is 0, we don't have to guard here */ + + i__2 = *n - (i__ + ib) + 1; + i__3 = i__ - 1; + dgemm_("Transpose", "No Transpose", &ib, &i__2, &i__3, &c_b14, + &a[i__ * a_dim1 + 1], lda, &a[(i__ + ib) * a_dim1 + + 1], lda, &c_b14, &a[i__ + (i__ + ib) * a_dim1], lda); + } + +/* Now, we update the diagonal block of interest */ + + dlall2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); + +/* Update the diagonal block with the part of A above the diagonal */ + + i__2 = i__ - 1; + dsyrk_("Upper", "Transpose", &ib, &i__2, &c_b14, &a[i__ * a_dim1 + + 1], lda, &c_b14, &a[i__ + i__ * a_dim1], lda); + +/* Only the first iteration will have IB be different from NB */ + + ib = nb; + } + } else { + i__1 = -nb; + for (i__ = ki; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { + +/* If not the first iteration */ + + if (i__ + ib <= *n) { + +/* Use the current diagonal block to update belowit */ +/* We guard this to prevent potentially referencing invalid memory */ + + i__2 = *n - (i__ + ib) + 1; + dtrmm_("Right", "Lower", "Transpose", "Non-Unit", &i__2, &ib, + &c_b14, &a[i__ + i__ * a_dim1], lda, &a[i__ + ib + + i__ * a_dim1], lda); + +/* Update the right of the current diagonal block with the */ +/* part of A above the current diagonal block */ +/* We don't do this on the last (first in the array) */ +/* However since we will not be accessing invalid */ +/* memory and dgemm promises to do nothing when */ +/* any input dimension is 0, we don't have to guard here */ + + i__2 = *n - (i__ + ib) + 1; + i__3 = i__ - 1; + dgemm_("No Transpose", "Transpose", &i__2, &ib, &i__3, &c_b14, + &a[i__ + ib + a_dim1], lda, &a[i__ + a_dim1], lda, & + c_b14, &a[i__ + ib + i__ * a_dim1], lda); + } + +/* Now, we update the diagonal block of interest */ + + dlall2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); + +/* Update the diagonal block with the part of A above the diagonal */ + + i__2 = i__ - 1; + dsyrk_("Lower", "No Transpose", &ib, &i__2, &c_b14, &a[i__ + + a_dim1], lda, &c_b14, &a[i__ + i__ * a_dim1], lda); + +/* Only the first iteration will have IB be different from NB */ + + ib = nb; + } + } + return; +} /* dlallm_blocked__ */ + diff --git a/lapack-netlib/SRC/dlallm_blocked.f b/lapack-netlib/SRC/dlallm_blocked.f new file mode 100644 index 0000000000..7ab6497012 --- /dev/null +++ b/lapack-netlib/SRC/dlallm_blocked.f @@ -0,0 +1,258 @@ +*> \brief \b DLALLM_BLOCKED computes the product LLH or UHU, 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 DLALLM_BLOCKED( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLALLM_BLOCKED computes the product L * L**T or U**T * U, 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**T * U, +*> 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 * L**T, 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 lallm +* +* ===================================================================== + SUBROUTINE DLALLM_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, K, KI +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLALL2, DTRMM, DGEMM, DSYRK +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. 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( 'DLALLM_BLOCKED', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'DLALLM_BLOCKED', UPLO, N, -1, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL DLALL2( UPLO, N, A, LDA, INFO ) + RETURN + END IF +* +* Determine the size of the last block +* + K = N / NB +* +* The last block starts at KI +* + KI = NB*K + 1 +* +* IB will hold the size of the block we are currently interested in +* + IB = N - KI + 1 + IF( UPPER ) THEN +* +* We go bottom to top computing one row at a time +* + DO I = KI, 1, -NB +* +* If not the first iteration +* + IF( I+IB.LE.N ) THEN +* +* Use the current diagonal block to update the right of it +* We guard this to prevent potentially referencing invalid memory +* + CALL DTRMM('Left', 'Upper', 'Transpose', 'Non-Unit', + $ IB, N-(I+IB)+1, ONE, A(I,I), LDA, A(I,I+IB), LDA) +* +* Update the right of the current diagonal block with the +* part of A above the current diagonal block +* We don't do this on the last (first in the array) +* However since we will not be accessing invalid +* memory and dgemm promises to do nothing when +* any input dimension is 0, we don't have to guard here +* + CALL DGEMM('Transpose', 'No Transpose', + $ IB, N-(I+IB)+1, I-1, + $ ONE, A(1,I), LDA, A(1,I+IB), LDA, + $ ONE, A(I,I+IB), LDA) + END IF +* +* Now, we update the diagonal block of interest +* + CALL DLALL2('Upper', IB, A(I,I), LDA, INFO) +* +* Update the diagonal block with the part of A above the diagonal +* + CALL DSYRK('Upper', 'Transpose', IB, I-1, + $ ONE, A(1,I), LDA, ONE, A(I,I), LDA) +* +* Only the first iteration will have IB be different from NB +* + IB = NB + END DO + ELSE + DO I = KI, 1, -NB +* +* If not the first iteration +* + IF( I+IB.LE.N ) THEN +* +* Use the current diagonal block to update belowit +* We guard this to prevent potentially referencing invalid memory +* + CALL DTRMM('Right', 'Lower', 'Transpose', 'Non-Unit', + $ N-(I+IB)+1, IB, ONE, A(I,I), LDA, A(I+IB,I), LDA) +* +* Update the right of the current diagonal block with the +* part of A above the current diagonal block +* We don't do this on the last (first in the array) +* However since we will not be accessing invalid +* memory and dgemm promises to do nothing when +* any input dimension is 0, we don't have to guard here +* + CALL DGEMM('No Transpose', 'Transpose', + $ N-(I+IB)+1, IB, I-1, + $ ONE, A(I+IB,1), LDA, A(I,1), LDA, + $ ONE, A(I+IB,I), LDA) + END IF +* +* Now, we update the diagonal block of interest +* + CALL DLALL2('Lower', IB, A(I,I), LDA, INFO) +* +* Update the diagonal block with the part of A above the diagonal +* + CALL DSYRK('Lower', 'No Transpose', IB, I-1, + $ ONE, A(I,1), LDA, ONE, A(I,I), LDA) +* +* Only the first iteration will have IB be different from NB +* + IB = NB + END DO + END IF + END SUBROUTINE diff --git a/lapack-netlib/SRC/dlallm_recursive.c b/lapack-netlib/SRC/dlallm_recursive.c new file mode 100644 index 0000000000..87b1e0a93a --- /dev/null +++ b/lapack-netlib/SRC/dlallm_recursive.c @@ -0,0 +1,509 @@ +#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)} + +/* Table of constant values */ + +static integer c__3 = 3; +static integer c_n1 = -1; +static doublereal c_b12 = 1.; + +/* > \brief \b DLALLM_ computes the product LLH or UHU, 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 DLALLM_( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* DOUBLE PRECISION A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLALLM_ computes the product L * L**T or U**T * U, 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 form 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**T * U, */ +/* > 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 * L**T, 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 lallm */ + +/* ===================================================================== */ +/* Subroutine */ void dlallm_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 *), dlall2_(char *, integer *, + doublereal *, integer *, integer *), xerbla_(char *, + integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + + +/* ===================================================================== */ + + +/* 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_("DLALLM_RECURSIVE", &i__1, (ftnlen)17); + 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, "DLALLM_RECURSIVE", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)17, ( + ftnlen)1); + if (*n <= nx) { + dlall2_(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**T U) */ + +/* Break apart U as */ + +/* |-----------------| */ +/* 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} and U_{22} are upper triangular and U_{12} is rectangular */ + +/* This gives us our operations as */ +/* |--------------------------| |-----------------| */ +/* ut(U**T U) = | U_{11}**T 0 | | U_{11} U_{12} | */ +/* | U_{12}**T U_{22}**T | | 0 U_{22} | */ +/* |--------------------------| |-----------------| */ + +/* Thus we get */ + +/* U_{11} = U_{11}**T U_{11} */ +/* U_{12} = U_{11}**T U_{12} */ + +/* U_{22} = U_{12}**T U_{12} + U_{22}**T U_{22} */ + +/* We break these operations apart as follows */ + +/* U_{22} = U_{22}**T U_{22} (This subroutine) */ +/* U_{22} = U_{12}**T U_{12} + U_{22} (SYRK) */ + +/* U_{12} = U_{11}**T U_{12} (TRMM) */ + +/* U_{11} = U_{11}**T U_{11} (This subroutine) */ + +/* Compute U_{22} */ + + i__1 = *n - k; + dlallm_recursive_(uplo, &i__1, &a[k + 1 + (k + 1) * a_dim1], lda, info); + i__1 = *n - k; + dsyrk_("Upper", "Transpose", &i__1, &k, &c_b12, &a[(k + 1) * a_dim1 + + 1], lda, &c_b12, &a[k + 1 + (k + 1) * a_dim1], lda); + +/* Compute U_{12} */ + + i__1 = *n - k; + dtrmm_("Left", "Upper", "Transpose", "Non-unit", &k, &i__1, &c_b12, & + a[a_offset], lda, &a[(k + 1) * a_dim1 + 1], lda); + +/* Compute U_{11} */ + + dlallm_recursive_(uplo, &k, &a[a_offset], lda, info); + } else { + +/* We are computing A = lt(LL**T) */ + +/* Break apart L as */ + +/* |-----------------| */ +/* 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} and L_{22} are lower triangular and L_{21} is rectangular */ + +/* This gives us our operations as */ +/* |--------------------| |-----------------------| */ +/* lt(LL**T) = | L_{11} 0 | | L_{11}**T L_{21}**T | */ +/* | L_{21} L_{22} | | 0 L_{22}**T | */ +/* |--------------------| |-----------------------| */ + +/* Thus we get */ + +/* L_{11} = L_{11} L_{11}**T */ +/* L_{21} = L_{21} L_{11}**T */ + +/* L_{22} = L_{21} L_{21}**T + L_{22} L_{22}**T */ + +/* We break these operations apart as follows */ + +/* L_{22} = L_{22} L_{22}**T (This subroutine) */ +/* L_{22} = L_{21} L_{21}**T + L_{22} (SYRK) */ + +/* L_{21} = L_{21} L_{11}**T (TRMM) */ + +/* L_{11} = L_{11} L_{11}**T (This subroutine) */ + +/* Compute L_{22} */ + + i__1 = *n - k; + dlallm_recursive_(uplo, &i__1, &a[k + 1 + (k + 1) * a_dim1], lda, info); + i__1 = *n - k; + dsyrk_("Lower", "No Transpose", &i__1, &k, &c_b12, &a[k + 1 + a_dim1], + lda, &c_b12, &a[k + 1 + (k + 1) * a_dim1], lda); + +/* Compute L_{21} */ + + i__1 = *n - k; + dtrmm_("Right", "Lower", "Transpose", "Non-unit", &i__1, &k, &c_b12, & + a[a_offset], lda, &a[k + 1 + a_dim1], lda); + +/* Compute L_{11} */ + + dlallm_recursive_(uplo, &k, &a[a_offset], lda, info); + } + return; +} /* dlallm___ */ + diff --git a/lapack-netlib/SRC/dlallm_recursive.f b/lapack-netlib/SRC/dlallm_recursive.f new file mode 100644 index 0000000000..4b28d7c5e3 --- /dev/null +++ b/lapack-netlib/SRC/dlallm_recursive.f @@ -0,0 +1,278 @@ +*> \brief \b DLALLM_RECURSIVE computes the product LLH or UHU, 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 DLALLM_RECURSIVE( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLALLM_RECURSIVE computes the product L * L**T or U**T * U, 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 form 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**T * U, +*> 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 * L**T, 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 lallm +* +* ===================================================================== + RECURSIVE SUBROUTINE DLALLM_RECURSIVE( UPLO, N, A, LDA, INFO ) +* +* .. 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,J,NX,K + DOUBLE PRECISION AII,AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLALL2, DSYRK, DTRMM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. 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( 'DLALLM_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, "DLALLM_RECURSIVE", UPLO, N, -1, -1, -1) + IF( N.LE.NX ) THEN + CALL DLALL2(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**T U) +* +* Break apart U as +* +* |-----------------| +* 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} and U_{22} are upper triangular and U_{12} is rectangular +* +* This gives us our operations as +* |--------------------------| |-----------------| +* ut(U**T U) = | U_{11}**T 0 | | U_{11} U_{12} | +* | U_{12}**T U_{22}**T | | 0 U_{22} | +* |--------------------------| |-----------------| +* +* Thus we get +* +* U_{11} = U_{11}**T U_{11} +* U_{12} = U_{11}**T U_{12} +* +* U_{22} = U_{12}**T U_{12} + U_{22}**T U_{22} +* +* We break these operations apart as follows +* +* U_{22} = U_{22}**T U_{22} (This subroutine) +* U_{22} = U_{12}**T U_{12} + U_{22} (SYRK) +* +* U_{12} = U_{11}**T U_{12} (TRMM) +* +* U_{11} = U_{11}**T U_{11} (This subroutine) +* +* Compute U_{22} +* + CALL DLALLM_RECURSIVE(UPLO, N-K, A(K+1,K+1), LDA, INFO) + CALL DSYRK('Upper', 'Transpose', N-K, K, ONE, A(1,K+1), LDA, + $ ONE, A(K+1,K+1), LDA) +* +* Compute U_{12} +* + CALL DTRMM('Left', 'Upper', 'Transpose', 'Non-unit', + $ K, N-K, ONE, A, LDA, A(1,K+1), LDA) +* +* Compute U_{11} +* + CALL DLALLM_RECURSIVE(UPLO, K, A, LDA, INFO) + ELSE +* +* We are computing A = lt(LL**T) +* +* Break apart L as +* +* |-----------------| +* 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} and L_{22} are lower triangular and L_{21} is rectangular +* +* This gives us our operations as +* |--------------------| |-----------------------| +* lt(LL**T) = | L_{11} 0 | | L_{11}**T L_{21}**T | +* | L_{21} L_{22} | | 0 L_{22}**T | +* |--------------------| |-----------------------| +* +* Thus we get +* +* L_{11} = L_{11} L_{11}**T +* L_{21} = L_{21} L_{11}**T +* +* L_{22} = L_{21} L_{21}**T + L_{22} L_{22}**T +* +* We break these operations apart as follows +* +* L_{22} = L_{22} L_{22}**T (This subroutine) +* L_{22} = L_{21} L_{21}**T + L_{22} (SYRK) +* +* L_{21} = L_{21} L_{11}**T (TRMM) +* +* L_{11} = L_{11} L_{11}**T (This subroutine) +* +* Compute L_{22} +* + CALL DLALLM_RECURSIVE(UPLO, N-K, A(K+1,K+1), LDA, INFO) + CALL DSYRK('Lower', 'No Transpose', N-K, K, + $ ONE, A(K+1,1), LDA, ONE, A(K+1,K+1), LDA) +* +* Compute L_{21} +* + CALL DTRMM('Right', 'Lower', 'Transpose', 'Non-unit', + $ N-K, K, ONE, A, LDA, A(K+1,1), LDA) +* +* Compute L_{11} +* + CALL DLALLM_RECURSIVE(UPLO, K, A, LDA, INFO) + END IF + + END SUBROUTINE diff --git a/lapack-netlib/SRC/ilaenv.c b/lapack-netlib/SRC/ilaenv.c index f34e83792b..51c62f127e 100644 --- a/lapack-netlib/SRC/ilaenv.c +++ b/lapack-netlib/SRC/ilaenv.c @@ -434,13 +434,13 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, /* EBCDIC character set */ - if ((ic >= 129 && ic <= 137) || (ic >= 145 && ic <= 153) || (ic >= 162 && - ic <= 169)) { + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 && + ic <= 169) { *(unsigned char *)subnam = (char) (ic + 64); for (i__ = 2; i__ <= 6; ++i__) { ic = *(unsigned char *)&subnam[i__ - 1]; - if ((ic >= 129 && ic <= 137) || (ic >= 145 && ic <= 153) || (ic >= - 162 && ic <= 169)) { + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= + 162 && ic <= 169) { *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64); } /* L30: */ @@ -751,6 +751,12 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, } else { nb = 32; } + } else if (s_cmp(c3, "LLM", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } } } else if (sname && s_cmp(c2, "ST", (ftnlen)2, (ftnlen)2) == 0) { if (s_cmp(c3, "EBZ", (ftnlen)3, (ftnlen)3) == 0) { @@ -944,6 +950,10 @@ integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, } 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, "LLM", (ftnlen)3, (ftnlen)3) == 0) { + +/* Note that this matches on *lallm*, but we only use it in */ +/* *lallm_recursive at the moment */ } else if (s_cmp(c3, "UUM", (ftnlen)3, (ftnlen)3) == 0) { /* Note that this matches on *lauum_recursive, which is the */ diff --git a/lapack-netlib/SRC/ilaenv.f b/lapack-netlib/SRC/ilaenv.f index 2622d44cc1..90f7256696 100644 --- a/lapack-netlib/SRC/ilaenv.f +++ b/lapack-netlib/SRC/ilaenv.f @@ -507,6 +507,12 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) ELSE NB = 32 END IF + ELSE IF( C3.EQ.'LLM' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF END IF ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN IF( C3.EQ.'EBZ' ) THEN @@ -679,6 +685,10 @@ 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.'LLM' ) THEN +* +* Note that this matches on *lallm*, but we only use it in +* *lallm_recursive at the moment ELSE IF( C3.EQ.'UUM' ) THEN * * Note that this matches on *lauum_recursive, which is the diff --git a/lapack-netlib/SRC/slall2.c b/lapack-netlib/SRC/slall2.c new file mode 100644 index 0000000000..59f889a08f --- /dev/null +++ b/lapack-netlib/SRC/slall2.c @@ -0,0 +1,421 @@ +#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)} + +/* Table of constant values */ + +static real c_b6 = 1.f; +static integer c__1 = 1; + +/* > \brief \b SLALL2 computes the product LLT or UTU, where U and L are upper or lower triangular matrices (u +nblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLALL2( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLALL2 computes the product L * L**T or U**T * U, 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 unblocked form 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**h * U, */ +/* > 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 * L**T, 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 lall2 */ + +/* ===================================================================== */ +/* Subroutine */ void slall2_(char *uplo, integer *n, real *a, integer *lda, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + real aii, ajj; + 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); + + +/* -- 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_("SLALL2", &i__1, (ftnlen)6); + return; + } + +/* Quick return if possible */ + + if (*n == 0) { + return; + } + if (upper) { + +/* Compute and store ut(U**T U) */ + + for (j = *n; j >= 1; --j) { + +/* Complex will want to store the conjugate */ + + ajj = a[j + j * a_dim1]; + if (j == 1) { + sscal_(n, &ajj, &a[a_offset], lda); + } else { + +/* complex version will need {c,z}gemm since the vector x is */ +/* conjugated (or a {c,z}gemcv-like statement) */ + + i__1 = j - 1; + i__2 = *n - j + 1; + sgemv_("Transpose", &i__1, &i__2, &c_b6, &a[j * a_dim1 + 1], + lda, &a[j * a_dim1 + 1], &c__1, &ajj, &a[j + j * + a_dim1], lda); + } + } + } else { + +/* Compute and store lt(LL**T) */ + + for (i__ = *n; i__ >= 1; --i__) { + +/* Complex will want to store the conjugate */ + + aii = a[i__ + i__ * a_dim1]; + if (i__ == 1) { + sscal_(n, &aii, &a[a_offset], &c__1); + } else { + +/* complex version will need {c,z}gemm since the vector x is */ +/* conjugated (or a {c,z}gemcv-like statement) */ + + i__1 = *n - i__ + 1; + i__2 = i__ - 1; + sgemv_("No Transpose", &i__1, &i__2, &c_b6, &a[i__ + a_dim1], + lda, &a[i__ + a_dim1], lda, &aii, &a[i__ + i__ * + a_dim1], &c__1); + } + } + } + return; +} /* slall2_ */ + diff --git a/lapack-netlib/SRC/slall2.f b/lapack-netlib/SRC/slall2.f new file mode 100644 index 0000000000..9b8aca156a --- /dev/null +++ b/lapack-netlib/SRC/slall2.f @@ -0,0 +1,194 @@ +*> \brief \b SLALL2 computes the product LLT or UTU, where U and L are upper or lower triangular matrices (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SLALL2( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLALL2 computes the product L * L**T or U**T * U, 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 unblocked form 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**h * U, +*> 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 * L**T, 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 lall2 +* +* ===================================================================== + SUBROUTINE SLALL2( 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,J + REAL AII,AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SSCAL, SGEMV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. 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( 'SLALL2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + IF( UPPER ) THEN +* +* Compute and store ut(U**T U) +* + DO J = N, 1, -1 +* +* Complex will want to store the conjugate +* + AJJ = A(J,J) + IF( J.EQ.1 ) THEN + CALL SSCAL(N, AJJ, A, LDA) + ELSE +* +* complex version will need {c,z}gemm since the vector x is +* conjugated (or a {c,z}gemcv-like statement) +* + CALL SGEMV('Transpose', J-1, N-J+1, ONE, + $ A(1,J), LDA, A(1,J), 1, AJJ, A(J,J), LDA) + END IF + END DO + ELSE +* +* Compute and store lt(LL**T) +* + DO I = N, 1, -1 +* +* Complex will want to store the conjugate +* + AII = A(I,I) + IF( I.EQ.1 ) THEN + CALL SSCAL(N, AII, A, 1) + ELSE +* +* complex version will need {c,z}gemm since the vector x is +* conjugated (or a {c,z}gemcv-like statement) +* + CALL SGEMV('No Transpose', N-I+1, I-1, ONE, + $ A(I,1), LDA, A(I,1), LDA, AII, A(I,I), 1) + END IF + END DO + END IF + END SUBROUTINE diff --git a/lapack-netlib/SRC/slallm.c b/lapack-netlib/SRC/slallm.c new file mode 100644 index 0000000000..9c85ab4a7a --- /dev/null +++ b/lapack-netlib/SRC/slallm.c @@ -0,0 +1,374 @@ +#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)} + +/* > \brief \b SLALLM computes the product LLT or UTU, 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/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLALLM( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLALLM computes the product L * L**T or U**T * U, 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 driver that idpatches to either blocked or recursive */ +/* > \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**T * U, */ +/* > 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 * L**T, 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 lallm */ + +/* ===================================================================== */ +/* Subroutine */ void slallm_(char *uplo, integer *n, real *a, integer *lda, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), slallm_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..-- */ + + +/* ===================================================================== */ + +/* 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_("SLALLM", &i__1, (ftnlen)6); + return; + } + +/* Quick return if possible */ + + if (*n == 0) { + return; + } + +/* 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...` */ + + slallm_recursive_(uplo, n, &a[a_offset], lda, info); + //slallm_blocked_(uplo, n, &a[a_offset], lda, info); + return; + +/* End of SLAUUM */ + +} /* slallm_ */ + diff --git a/lapack-netlib/SRC/slallm.f b/lapack-netlib/SRC/slallm.f new file mode 100644 index 0000000000..592ae39b0f --- /dev/null +++ b/lapack-netlib/SRC/slallm.f @@ -0,0 +1,159 @@ +*> \brief \b SLALLM computes the product LLT or UTU, 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/ +* +* Definition: +* =========== +* +* SUBROUTINE SLALLM( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLALLM computes the product L * L**T or U**T * U, 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 driver that idpatches to either blocked or recursive +*> \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**T * U, +*> 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 * L**T, 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 lallm +* +* ===================================================================== + SUBROUTINE SLALLM( 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, * ) +* .. +* +* ===================================================================== +* .. +* .. Local Scalars .. + LOGICAL UPPER +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SLALLM_BLOCKED, + $ SLALLM_RECURSIVE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. 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( 'SLALLM', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* 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 SLALLM_RECURSIVE(UPLO, N, A, LDA, INFO) +* CALL SLALLM_BLOCKED(UPLO, N, A, LDA, INFO) + RETURN +* +* End of SLAUUM +* + END SUBROUTINE diff --git a/lapack-netlib/SRC/slallm_blocked.c b/lapack-netlib/SRC/slallm_blocked.c new file mode 100644 index 0000000000..b6c7de9e7d --- /dev/null +++ b/lapack-netlib/SRC/slallm_blocked.c @@ -0,0 +1,497 @@ +#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)} + +/* Table of constant values */ + +static integer c__1 = 1; +static integer c_n1 = -1; +static real c_b14 = 1.f; + +/* > \brief \b SLALLM_BLOCKED computes the product LLT or UTU, 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 SLALLM_BLOCKED( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLALLM_BLOCKED computes the product L * L**T or U**T * U, 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**T * U, */ +/* > 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 * L**T, 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 lallm */ + +/* ===================================================================== */ +/* Subroutine */ void slallm_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; + + /* Local variables */ + integer i__, k, ib, nb, ki; + 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 * + ), slall2_(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_("SLALLM_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, "SLALLM_BLOCKED", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)14, (ftnlen)1); + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + slall2_(uplo, n, &a[a_offset], lda, info); + return; + } + +/* Determine the size of the last block */ + + k = *n / nb; + +/* The last block starts at KI */ + + ki = nb * k + 1; + +/* IB will hold the size of the block we are currently interested in */ + + ib = *n - ki + 1; + if (upper) { + +/* We go bottom to top computing one row at a time */ + + i__1 = -nb; + for (i__ = ki; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { + +/* If not the first iteration */ + + if (i__ + ib <= *n) { + +/* Use the current diagonal block to update the right of it */ +/* We guard this to prevent potentially referencing invalid memory */ + + i__2 = *n - (i__ + ib) + 1; + strmm_("Left", "Upper", "Transpose", "Non-Unit", &ib, &i__2, & + c_b14, &a[i__ + i__ * a_dim1], lda, &a[i__ + (i__ + + ib) * a_dim1], lda); + +/* Update the right of the current diagonal block with the */ +/* part of A above the current diagonal block */ +/* We don't do this on the last (first in the array) */ +/* However since we will not be accessing invalid */ +/* memory and sgemm promises to do nothing when */ +/* any input dimension is 0, we don't have to guard here */ + + i__2 = *n - (i__ + ib) + 1; + i__3 = i__ - 1; + sgemm_("Transpose", "No Transpose", &ib, &i__2, &i__3, &c_b14, + &a[i__ * a_dim1 + 1], lda, &a[(i__ + ib) * a_dim1 + + 1], lda, &c_b14, &a[i__ + (i__ + ib) * a_dim1], lda); + } + +/* Now, we update the diagonal block of interest */ + + slall2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); + +/* Update the diagonal block with the part of A above the diagonal */ + + i__2 = i__ - 1; + ssyrk_("Upper", "Transpose", &ib, &i__2, &c_b14, &a[i__ * a_dim1 + + 1], lda, &c_b14, &a[i__ + i__ * a_dim1], lda); + +/* Only the first iteration will have IB be different from NB */ + + ib = nb; + } + } else { + i__1 = -nb; + for (i__ = ki; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { + +/* If not the first iteration */ + + if (i__ + ib <= *n) { + +/* Use the current diagonal block to update below it */ +/* We guard this to prevent potentially referencing invalid memory */ + + i__2 = *n - (i__ + ib) + 1; + strmm_("Right", "Lower", "Transpose", "Non-Unit", &i__2, &ib, + &c_b14, &a[i__ + i__ * a_dim1], lda, &a[i__ + ib + + i__ * a_dim1], lda); + +/* Update the right of the current diagonal block with the */ +/* part of A above the current diagonal block */ +/* We don't do this on the last (first in the array) */ +/* However since we will not be accessing invalid */ +/* memory and sgemm promises to do nothing when */ +/* any input dimension is 0, we don't have to guard here */ + + i__2 = *n - (i__ + ib) + 1; + i__3 = i__ - 1; + sgemm_("No Transpose", "Transpose", &i__2, &ib, &i__3, &c_b14, + &a[i__ + ib + a_dim1], lda, &a[i__ + a_dim1], lda, & + c_b14, &a[i__ + ib + i__ * a_dim1], lda); + } + +/* Now, we update the diagonal block of interest */ + + slall2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); + +/* Update the diagonal block with the part of A above the diagonal */ + + i__2 = i__ - 1; + ssyrk_("Lower", "No Transpose", &ib, &i__2, &c_b14, &a[i__ + + a_dim1], lda, &c_b14, &a[i__ + i__ * a_dim1], lda); + +/* Only the first iteration will have IB be different from NB */ + + ib = nb; + } + } + return; +} /* slallm_blocked__ */ + diff --git a/lapack-netlib/SRC/slallm_blocked.f b/lapack-netlib/SRC/slallm_blocked.f new file mode 100644 index 0000000000..384aa0d563 --- /dev/null +++ b/lapack-netlib/SRC/slallm_blocked.f @@ -0,0 +1,258 @@ +*> \brief \b SLALLM_BLOCKED computes the product LLT or UTU, 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 SLALLM_BLOCKED( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLALLM_BLOCKED computes the product L * L**T or U**T * U, 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**T * U, +*> 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 * L**T, 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 lallm +* +* ===================================================================== + SUBROUTINE SLALLM_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, K, KI +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SLALL2, STRMM, SGEMM, SSYRK +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. 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( 'SLALLM_BLOCKED', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'SLALLM_BLOCKED', UPLO, N, -1, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL SLALL2( UPLO, N, A, LDA, INFO ) + RETURN + END IF +* +* Determine the size of the last block +* + K = N / NB +* +* The last block starts at KI +* + KI = NB*K + 1 +* +* IB will hold the size of the block we are currently interested in +* + IB = N - KI + 1 + IF( UPPER ) THEN +* +* We go bottom to top computing one row at a time +* + DO I = KI, 1, -NB +* +* If not the first iteration +* + IF( I+IB.LE.N ) THEN +* +* Use the current diagonal block to update the right of it +* We guard this to prevent potentially referencing invalid memory +* + CALL STRMM('Left', 'Upper', 'Transpose', 'Non-Unit', + $ IB, N-(I+IB)+1, ONE, A(I,I), LDA, A(I,I+IB), LDA) +* +* Update the right of the current diagonal block with the +* part of A above the current diagonal block +* We don't do this on the last (first in the array) +* However since we will not be accessing invalid +* memory and sgemm promises to do nothing when +* any input dimension is 0, we don't have to guard here +* + CALL SGEMM('Transpose', 'No Transpose', + $ IB, N-(I+IB)+1, I-1, + $ ONE, A(1,I), LDA, A(1,I+IB), LDA, + $ ONE, A(I,I+IB), LDA) + END IF +* +* Now, we update the diagonal block of interest +* + CALL SLALL2('Upper', IB, A(I,I), LDA, INFO) +* +* Update the diagonal block with the part of A above the diagonal +* + CALL SSYRK('Upper', 'Transpose', IB, I-1, + $ ONE, A(1,I), LDA, ONE, A(I,I), LDA) +* +* Only the first iteration will have IB be different from NB +* + IB = NB + END DO + ELSE + DO I = KI, 1, -NB +* +* If not the first iteration +* + IF( I+IB.LE.N ) THEN +* +* Use the current diagonal block to update below it +* We guard this to prevent potentially referencing invalid memory +* + CALL STRMM('Right', 'Lower', 'Transpose', 'Non-Unit', + $ N-(I+IB)+1, IB, ONE, A(I,I), LDA, A(I+IB,I), LDA) +* +* Update the right of the current diagonal block with the +* part of A above the current diagonal block +* We don't do this on the last (first in the array) +* However since we will not be accessing invalid +* memory and sgemm promises to do nothing when +* any input dimension is 0, we don't have to guard here +* + CALL SGEMM('No Transpose', 'Transpose', + $ N-(I+IB)+1, IB, I-1, + $ ONE, A(I+IB,1), LDA, A(I,1), LDA, + $ ONE, A(I+IB,I), LDA) + END IF +* +* Now, we update the diagonal block of interest +* + CALL SLALL2('Lower', IB, A(I,I), LDA, INFO) +* +* Update the diagonal block with the part of A above the diagonal +* + CALL SSYRK('Lower', 'No Transpose', IB, I-1, + $ ONE, A(I,1), LDA, ONE, A(I,I), LDA) +* +* Only the first iteration will have IB be different from NB +* + IB = NB + END DO + END IF + END SUBROUTINE diff --git a/lapack-netlib/SRC/slallm_recursive.c b/lapack-netlib/SRC/slallm_recursive.c new file mode 100644 index 0000000000..5bd070cc87 --- /dev/null +++ b/lapack-netlib/SRC/slallm_recursive.c @@ -0,0 +1,507 @@ +#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)} + +/* Table of constant values */ + +static integer c__3 = 3; +static integer c_n1 = -1; +static real c_b12 = 1.f; + +/* > \brief \b SLALLM_ computes the product LLH or UHU, 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 SLALLM_( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLALLM_ computes the product L * L**T or U**T * U, 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 form 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**T * U, */ +/* > 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 * L**T, 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 lallm */ + +/* ===================================================================== */ +/* Subroutine */ void slallm_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 * + ), slall2_(char *, integer *, real *, integer *, + integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + + +/* ===================================================================== */ + + +/* 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_("SLALLM__RECURSIVE", &i__1, (ftnlen)17); + 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, "SLALLM_RECURSIVE", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)17, ( + ftnlen)1); + if (*n <= nx) { + slall2_(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**T U) */ + +/* Break apart U as */ + +/* |-----------------| */ +/* 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} and U_{22} are upper triangular and U_{12} is rectangular */ + +/* This gives us our operations as */ +/* |--------------------------| |-----------------| */ +/* ut(U**T U) = | U_{11}**T 0 | | U_{11} U_{12} | */ +/* | U_{12}**T U_{22}**T | | 0 U_{22} | */ +/* |--------------------------| |-----------------| */ + +/* Thus we get */ + +/* U_{11} = U_{11}**T U_{11} */ +/* U_{12} = U_{11}**T U_{12} */ + +/* U_{22} = U_{12}**T U_{12} + U_{22}**T U_{22} */ + +/* We break these operations apart as follows */ + +/* U_{22} = U_{22}**T U_{22} (This subroutine) */ +/* U_{22} = U_{12}**T U_{12} + U_{22} (SYRK) */ + +/* U_{12} = U_{11}**T U_{12} (TRMM) */ + +/* U_{11} = U_{11}**T U_{11} (This subroutine) */ + +/* Compute U_{22} */ + + i__1 = *n - k; + slallm_recursive_(uplo, &i__1, &a[k + 1 + (k + 1) * a_dim1], lda, info); + i__1 = *n - k; + ssyrk_("Upper", "Transpose", &i__1, &k, &c_b12, &a[(k + 1) * a_dim1 + + 1], lda, &c_b12, &a[k + 1 + (k + 1) * a_dim1], lda); + +/* Compute U_{12} */ + + i__1 = *n - k; + strmm_("Left", "Upper", "Transpose", "Non-unit", &k, &i__1, &c_b12, & + a[a_offset], lda, &a[(k + 1) * a_dim1 + 1], lda); + +/* Compute U_{11} */ + + slallm_recursive_(uplo, &k, &a[a_offset], lda, info); + } else { + +/* We are computing A = lt(LL**T) */ + +/* Break apart L as */ + +/* |-----------------| */ +/* 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} and L_{22} are lower triangular and L_{21} is rectangular */ + +/* This gives us our operations as */ +/* |--------------------| |-----------------------| */ +/* lt(LL**T) = | L_{11} 0 | | L_{11}**T L_{21}**T | */ +/* | L_{21} L_{22} | | 0 L_{22}**T | */ +/* |--------------------| |-----------------------| */ + +/* Thus we get */ + +/* L_{11} = L_{11} L_{11}**T */ +/* L_{21} = L_{21} L_{11}**T */ + +/* L_{22} = L_{21} L_{21}**T + L_{22} L_{22}**T */ + +/* We break these operations apart as follows */ + +/* L_{22} = L_{22} L_{22}**T (This subroutine) */ +/* L_{22} = L_{21} L_{21}**T + L_{22} (SYRK) */ + +/* L_{21} = L_{21} L_{11}**T (TRMM) */ + +/* L_{11} = L_{11} L_{11}**T (This subroutine) */ + +/* Compute L_{22} */ + + i__1 = *n - k; + slallm_recursive_(uplo, &i__1, &a[k + 1 + (k + 1) * a_dim1], lda, info); + i__1 = *n - k; + ssyrk_("Lower", "No Transpose", &i__1, &k, &c_b12, &a[k + 1 + a_dim1], + lda, &c_b12, &a[k + 1 + (k + 1) * a_dim1], lda); + +/* Compute L_{21} */ + + i__1 = *n - k; + strmm_("Right", "Lower", "Transpose", "Non-unit", &i__1, &k, &c_b12, & + a[a_offset], lda, &a[k + 1 + a_dim1], lda); + +/* Compute L_{11} */ + + slallm_recursive_(uplo, &k, &a[a_offset], lda, info); + } + return; +} /* slallm___ */ + diff --git a/lapack-netlib/SRC/slallm_recursive.f b/lapack-netlib/SRC/slallm_recursive.f new file mode 100644 index 0000000000..420490f514 --- /dev/null +++ b/lapack-netlib/SRC/slallm_recursive.f @@ -0,0 +1,277 @@ +*> \brief \b SLALLM_RECURSIVE computes the product LLH or UHU, 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: +* =========== +* +* RECURSIVE SUBROUTINE SLALLM_RECURSIVE( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLALLM_RECURSIVE computes the product L * L**T or U**T * U, 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 form 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**T * U, +*> 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 * L**T, 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 lallm +* +* ===================================================================== + RECURSIVE SUBROUTINE SLALLM_RECURSIVE( UPLO, N, A, LDA, INFO ) +* +* .. 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,J,NX,K + REAL AII,AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SLALL2, SSYRK, STRMM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. 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( 'SLALLM_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, "SLALLM_RECURSIVE", UPLO, N, -1, -1, -1) + IF( N.LE.NX ) THEN + CALL SLALL2(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**T U) +* +* Break apart U as +* +* |-----------------| +* 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} and U_{22} are upper triangular and U_{12} is rectangular +* +* This gives us our operations as +* |--------------------------| |-----------------| +* ut(U**T U) = | U_{11}**T 0 | | U_{11} U_{12} | +* | U_{12}**T U_{22}**T | | 0 U_{22} | +* |--------------------------| |-----------------| +* +* Thus we get +* +* U_{11} = U_{11}**T U_{11} +* U_{12} = U_{11}**T U_{12} +* +* U_{22} = U_{12}**T U_{12} + U_{22}**T U_{22} +* +* We break these operations apart as follows +* +* U_{22} = U_{22}**T U_{22} (This subroutine) +* U_{22} = U_{12}**T U_{12} + U_{22} (SYRK) +* +* U_{12} = U_{11}**T U_{12} (TRMM) +* +* U_{11} = U_{11}**T U_{11} (This subroutine) +* +* Compute U_{22} +* + CALL SLALLM_RECURSIVE(UPLO, N-K, A(K+1,K+1), LDA, INFO) + CALL SSYRK('Upper', 'Transpose', N-K, K, ONE, A(1,K+1), LDA, + $ ONE, A(K+1,K+1), LDA) +* +* Compute U_{12} +* + CALL STRMM('Left', 'Upper', 'Transpose', 'Non-unit', + $ K, N-K, ONE, A, LDA, A(1,K+1), LDA) +* +* Compute U_{11} +* + CALL SLALLM_RECURSIVE(UPLO, K, A, LDA, INFO) + ELSE +* +* We are computing A = lt(LL**T) +* +* Break apart L as +* +* |-----------------| +* 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} and L_{22} are lower triangular and L_{21} is rectangular +* +* This gives us our operations as +* |--------------------| |-----------------------| +* lt(LL**T) = | L_{11} 0 | | L_{11}**T L_{21}**T | +* | L_{21} L_{22} | | 0 L_{22}**T | +* |--------------------| |-----------------------| +* +* Thus we get +* +* L_{11} = L_{11} L_{11}**T +* L_{21} = L_{21} L_{11}**T +* +* L_{22} = L_{21} L_{21}**T + L_{22} L_{22}**T +* +* We break these operations apart as follows +* +* L_{22} = L_{22} L_{22}**T (This subroutine) +* L_{22} = L_{21} L_{21}**T + L_{22} (SYRK) +* +* L_{21} = L_{21} L_{11}**T (TRMM) +* +* L_{11} = L_{11} L_{11}**T (This subroutine) +* +* Compute L_{22} +* + CALL SLALLM_RECURSIVE(UPLO, N-K, A(K+1,K+1), LDA, INFO) + CALL SSYRK('Lower', 'No Transpose', N-K, K, + $ ONE, A(K+1,1), LDA, ONE, A(K+1,K+1), LDA) +* +* Compute L_{21} +* + CALL STRMM('Right', 'Lower', 'Transpose', 'Non-unit', + $ N-K, K, ONE, A, LDA, A(K+1,1), LDA) +* +* Compute L_{11} +* + CALL SLALLM_RECURSIVE(UPLO, K, A, LDA, INFO) + END IF + + END SUBROUTINE diff --git a/lapack-netlib/SRC/zlall2.c b/lapack-netlib/SRC/zlall2.c new file mode 100644 index 0000000000..08aed02f31 --- /dev/null +++ b/lapack-netlib/SRC/zlall2.c @@ -0,0 +1,475 @@ +#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 _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#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);} +#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)} + +/* -- 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 doublecomplex c_b1 = {1.,0.}; +static integer c__1 = 1; + +/* > \brief \b ZLALL2 computes the product LLH or UHU, where U and L are upper or lower triangular matrices (u +nblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLALL2( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLALL2 computes the product L * L**H or U**H * U, 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 unblocked form 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**h * U, */ +/* > 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 * L**H, 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 lall2 */ + +/* ===================================================================== */ +/* Subroutine */ void zlall2_(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; + + /* Local variables */ + integer i__, j; + doublecomplex aii, ajj; + extern logical lsame_(char *, char *); + extern /* Subroutine */ void zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), zgemm_(char *, char *, integer *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + logical upper; + extern /* Subroutine */ void xerbla_(char *, integer *, 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_("ZLALL2", &i__1, (ftnlen)6); + return; + } + +/* Quick return if possible */ + + if (*n == 0) { + return; + } + if (upper) { + +/* Compute and store ut(U**H U) */ + + for (j = *n; j >= 1; --j) { + +/* Complex will want to store the conjugate */ + + d_cnjg(&z__1, &a[j + j * a_dim1]); + ajj.r = z__1.r, ajj.i = z__1.i; + if (j == 1) { + zscal_(n, &ajj, &a[a_offset], lda); + } else { + +/* complex version will need {c,z}gemm since the vector x is */ +/* conjugated (or a {c,z}gemcv-like statement) */ + + i__1 = *n - j + 1; + i__2 = j - 1; + zgemm_("Conjugate Transpose", "No Transpose", &c__1, &i__1, & + i__2, &c_b1, &a[j * a_dim1 + 1], lda, &a[j * a_dim1 + + 1], lda, &ajj, &a[j + j * a_dim1], lda); + } + i__1 = j + j * a_dim1; + i__2 = j + j * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + } + } else { + +/* Compute and store lt(LL**H) */ + + for (i__ = *n; i__ >= 1; --i__) { + +/* Complex will want to store the conjugate */ + + d_cnjg(&z__1, &a[i__ + i__ * a_dim1]); + aii.r = z__1.r, aii.i = z__1.i; + if (i__ == 1) { + zscal_(n, &aii, &a[a_offset], &c__1); + } else { + +/* complex version will need {c,z}gemm since the vector x is */ +/* conjugated (or a {c,z}gemcv-like statement) */ + + i__1 = *n - i__ + 1; + i__2 = i__ - 1; + zgemm_("No Transpose", "Conjugate Transpose", &i__1, &c__1, & + i__2, &c_b1, &a[i__ + a_dim1], lda, &a[i__ + a_dim1], + lda, &aii, &a[i__ + i__ * a_dim1], lda); + } + i__1 = i__ + i__ * a_dim1; + i__2 = i__ + i__ * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + } + } + return; +} /* zlall2_ */ + diff --git a/lapack-netlib/SRC/zlall2.f b/lapack-netlib/SRC/zlall2.f new file mode 100644 index 0000000000..106a5c56e8 --- /dev/null +++ b/lapack-netlib/SRC/zlall2.f @@ -0,0 +1,200 @@ +*> \brief \b ZLALL2 computes the product LLH or UHU, where U and L are upper or lower triangular matrices (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZLALL2( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLALL2 computes the product L * L**H or U**H * U, 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 unblocked form 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**h * U, +*> 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 * L**H, 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 lall2 +* +* ===================================================================== + SUBROUTINE ZLALL2( 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 ONE + PARAMETER ( ONE = (1.0D+0,0.0D+0) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I,J + COMPLEX*16 AII,AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZSCAL, ZGEMM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, DCONJG +* .. +* .. 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( 'ZLALL2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + IF( UPPER ) THEN +* +* Compute and store ut(U**H U) +* + DO J = N, 1, -1 +* +* Complex will want to store the conjugate +* + AJJ = DCONJG(A(J,J)) + IF( J.EQ.1 ) THEN + CALL ZSCAL(N, AJJ, A, LDA) + ELSE +* +* complex version will need {c,z}gemm since the vector x is +* conjugated (or a {c,z}gemcv-like statement) +* + CALL ZGEMM('Conjugate Transpose', 'No Transpose', + $ 1, N-J+1, J-1, ONE, A(1,J), LDA, A(1,J), LDA, + $ AJJ, A(J,J), LDA) + END IF + A(J,J) = DBLE(A(J,J)) + END DO + ELSE +* +* Compute and store lt(LL**H) +* + DO I = N, 1, -1 +* +* Complex will want to store the conjugate +* + AII = DCONJG(A(I,I)) + IF( I.EQ.1 ) THEN + CALL ZSCAL(N, AII, A, 1) + ELSE +* +* complex version will need {c,z}gemm since the vector x is +* conjugated (or a {c,z}gemcv-like statement) +* + CALL ZGEMM('No Transpose', 'Conjugate Transpose', + $ N-I+1, 1, I-1, ONE, A(I,1), LDA, A(I,1), LDA, + $ AII, A(I,I), LDA) + END IF + A(I,I) = DBLE(A(I,I)) + END DO + END IF + END SUBROUTINE diff --git a/lapack-netlib/SRC/zlallm.c b/lapack-netlib/SRC/zlallm.c new file mode 100644 index 0000000000..50714aafd6 --- /dev/null +++ b/lapack-netlib/SRC/zlallm.c @@ -0,0 +1,414 @@ +#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 _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#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);} +#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)} + +/* -- translated by f2c (version 20000121). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + +/* > \brief \b ZLALLM computes the product LLH or UHU, 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/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLALLM( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLALLM computes the product L * L**H or U**H * U, 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. Regardless, the diagonal elements are explicitly */ +/* > set to be real by casting to DBLE before exit. */ +/* > This is the driver that idpatches to either blocked or recursive */ +/* > \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**h * U, */ +/* > 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 * L**H, 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 lallm */ + +/* ===================================================================== */ +/* Subroutine */ void zlallm_(char *uplo, integer *n, doublecomplex *a, + integer *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), zlallm_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..-- */ + + +/* ===================================================================== */ + +/* 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_("ZLALLM", &i__1, (ftnlen)6); + return; + } + +/* Quick return if possible */ + + if (*n == 0) { + return; + } + +/* 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...` */ + + zlallm_recursive_(uplo, n, &a[a_offset], lda, info); + //zlallm_blocked_(uplo, n, &a[a_offset], lda, info); + return; + +/* End of ZLAUUM */ + +} /* zlallm_ */ + diff --git a/lapack-netlib/SRC/zlallm.f b/lapack-netlib/SRC/zlallm.f new file mode 100644 index 0000000000..078c56ccc2 --- /dev/null +++ b/lapack-netlib/SRC/zlallm.f @@ -0,0 +1,162 @@ +*> \brief \b ZLALLM computes the product LLH or UHU, 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/ +* +* Definition: +* =========== +* +* SUBROUTINE ZLALLM( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLALLM computes the product L * L**H or U**H * U, 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. Regardless, the diagonal elements are explicitly +*> set to be real by casting to DBLE before exit. +*> This is the driver that idpatches to either blocked or recursive +*> \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**h * U, +*> 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 * L**H, 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 lallm +* +* ===================================================================== + SUBROUTINE ZLALLM( 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, * ) +* .. +* +* ===================================================================== +* .. +* .. Local Scalars .. + LOGICAL UPPER +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLALLM_BLOCKED, + $ ZLALLM_RECURSIVE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. 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( 'ZLALLM', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* 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 ZLALLM_RECURSIVE(UPLO, N, A, LDA, INFO) +* CALL ZLALLM_BLOCKED(UPLO, N, A, LDA, INFO) + RETURN +* +* End of ZLAUUM +* + END SUBROUTINE diff --git a/lapack-netlib/SRC/zlallm_blocked.c b/lapack-netlib/SRC/zlallm_blocked.c new file mode 100644 index 0000000000..be88a979f6 --- /dev/null +++ b/lapack-netlib/SRC/zlallm_blocked.c @@ -0,0 +1,540 @@ +#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 _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#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);} +#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)} + +/* -- 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 doublecomplex c_b1 = {1.,0.}; +static integer c__1 = 1; +static integer c_n1 = -1; +static doublereal c_b20 = 1.; + +/* > \brief \b ZLALLM computes the product LLH or UHU, where U and L are upper or lower triangular matrices (b +locked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLALLM( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLALLM computes the product L * L**H or U**H * U, 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. Regardless, the diagonal of A is explicitly */ +/* > set to real by casting to DBLE before exit. */ +/* > */ +/* > 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**H * U, */ +/* > 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 * L**H, and the strictly */ +/* > upper triangular part of A is not referenced. Regardless, */ +/* > the diagonal of A is 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 lallm */ + +/* ===================================================================== */ +/* Subroutine */ void zlallm_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; + + /* Local variables */ + integer i__, k, ib, nb, ki; + 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 *), + zlall2_(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_("ZLALLM_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, "ZLALLM_BLOCKED", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)14, (ftnlen)1); + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + zlall2_(uplo, n, &a[a_offset], lda, info); + return; + } + +/* Determine the size of the last block */ + + k = *n / nb; + +/* The last block starts at KI */ + + ki = nb * k + 1; + +/* IB will hold the size of the block we are currently interested in */ + + ib = *n - ki + 1; + if (upper) { + +/* We go bottom to top computing one row at a time */ + + i__1 = -nb; + for (i__ = ki; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { + +/* If not the first iteration */ + + if (i__ + ib <= *n) { + +/* Use the current diagonal block to update the right of it */ +/* We guard this to prevent potentially referencing invalid memory */ + + i__2 = *n - (i__ + ib) + 1; + ztrmm_("Left", "Upper", "Conjguate", "Non-Unit", &ib, &i__2, & + c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__ + (i__ + ib) + * a_dim1], lda); + +/* Update the right of the current diagonal block with the */ +/* part of A above the current diagonal block */ +/* We don't do this on the last (first in the array) */ +/* However since we will not be accessing invalid */ +/* memory and zgemm promises to do nothing when */ +/* any input dimension is 0, we don't have to guard here */ + + i__2 = *n - (i__ + ib) + 1; + i__3 = i__ - 1; + zgemm_("Conjguate", "No Transpose", &ib, &i__2, &i__3, &c_b1, + &a[i__ * a_dim1 + 1], lda, &a[(i__ + ib) * a_dim1 + 1] + , lda, &c_b1, &a[i__ + (i__ + ib) * a_dim1], lda); + } + +/* Now, we update the diagonal block of interest */ + + zlall2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); + +/* Update the diagonal block with the part of A above the diagonal */ + + i__2 = i__ - 1; + zherk_("Upper", "Conjguate", &ib, &i__2, &c_b20, &a[i__ * a_dim1 + + 1], lda, &c_b20, &a[i__ + i__ * a_dim1], lda); + +/* Only the first iteration will have IB be different from NB */ + + ib = nb; + } + } else { + i__1 = -nb; + for (i__ = ki; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { + +/* If not the first iteration */ + + if (i__ + ib <= *n) { + +/* Use the current diagonal block to update belowit */ +/* We guard this to prevent potentially referencing invalid memory */ + + i__2 = *n - (i__ + ib) + 1; + ztrmm_("Right", "Lower", "Conjguate", "Non-Unit", &i__2, &ib, + &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__ + ib + i__ + * a_dim1], lda); + +/* Update the right of the current diagonal block with the */ +/* part of A above the current diagonal block */ +/* We don't do this on the last (first in the array) */ +/* However since we will not be accessing invalid */ +/* memory and zgemm promises to do nothing when */ +/* any input dimension is 0, we don't have to guard here */ + + i__2 = *n - (i__ + ib) + 1; + i__3 = i__ - 1; + zgemm_("No Transpose", "Conjguate", &i__2, &ib, &i__3, &c_b1, + &a[i__ + ib + a_dim1], lda, &a[i__ + a_dim1], lda, & + c_b1, &a[i__ + ib + i__ * a_dim1], lda); + } + +/* Now, we update the diagonal block of interest */ + + zlall2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); + +/* Update the diagonal block with the part of A above the diagonal */ + + i__2 = i__ - 1; + zherk_("Lower", "No Transpose", &ib, &i__2, &c_b20, &a[i__ + + a_dim1], lda, &c_b20, &a[i__ + i__ * a_dim1], lda); + +/* Only the first iteration will have IB be different from NB */ + + ib = nb; + } + } + return; +} /* zlallm_blocked__ */ + diff --git a/lapack-netlib/SRC/zlallm_blocked.f b/lapack-netlib/SRC/zlallm_blocked.f new file mode 100644 index 0000000000..587fbb4d74 --- /dev/null +++ b/lapack-netlib/SRC/zlallm_blocked.f @@ -0,0 +1,262 @@ +*> \brief \b ZLALLM computes the product LLH or UHU, 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 ZLALLM( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLALLM computes the product L * L**H or U**H * U, 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. Regardless, the diagonal of A is explicitly +*> set to real by casting to DBLE before exit. +*> +*> 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**H * U, +*> 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 * L**H, and the strictly +*> upper triangular part of A is not referenced. Regardless, +*> the diagonal of A is 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 lallm +* +* ===================================================================== + SUBROUTINE ZLALLM_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 + COMPLEX*16 ZONE + PARAMETER ( ONE = 1.0D+0, ZONE = (1.0D+0, 0.0D+0) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IB, NB, K, KI +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLALL2, ZTRMM, ZGEMM, ZHERK +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. 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( 'DLALLM', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'ZLALLM_BLOCKED', UPLO, N, -1, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL ZLALL2( UPLO, N, A, LDA, INFO ) + RETURN + END IF +* +* Determine the size of the last block +* + K = N / NB +* +* The last block starts at KI +* + KI = NB*K + 1 +* +* IB will hold the size of the block we are currently interested in +* + IB = N - KI + 1 + IF( UPPER ) THEN +* +* We go bottom to top computing one row at a time +* + DO I = KI, 1, -NB +* +* If not the first iteration +* + IF( I+IB.LE.N ) THEN +* +* Use the current diagonal block to update the right of it +* We guard this to prevent potentially referencing invalid memory +* + CALL ZTRMM('Left', 'Upper', 'Conjguate', 'Non-Unit', + $ IB, N-(I+IB)+1, ZONE, A(I,I), LDA, A(I,I+IB), LDA) +* +* Update the right of the current diagonal block with the +* part of A above the current diagonal block +* We don't do this on the last (first in the array) +* However since we will not be accessing invalid +* memory and zgemm promises to do nothing when +* any input dimension is 0, we don't have to guard here +* + CALL ZGEMM('Conjguate', 'No Transpose', + $ IB, N-(I+IB)+1, I-1, + $ ZONE, A(1,I), LDA, A(1,I+IB), LDA, + $ ZONE, A(I,I+IB), LDA) + END IF +* +* Now, we update the diagonal block of interest +* + CALL ZLALL2('Upper', IB, A(I,I), LDA, INFO) +* +* Update the diagonal block with the part of A above the diagonal +* + CALL ZHERK('Upper', 'Conjguate', IB, I-1, + $ ONE, A(1,I), LDA, ONE, A(I,I), LDA) +* +* Only the first iteration will have IB be different from NB +* + IB = NB + END DO + ELSE + DO I = KI, 1, -NB +* +* If not the first iteration +* + IF( I+IB.LE.N ) THEN +* +* Use the current diagonal block to update belowit +* We guard this to prevent potentially referencing invalid memory +* + CALL ZTRMM('Right', 'Lower', 'Conjguate', 'Non-Unit', + $ N-(I+IB)+1, IB, ZONE, A(I,I), LDA, A(I+IB,I), LDA) +* +* Update the right of the current diagonal block with the +* part of A above the current diagonal block +* We don't do this on the last (first in the array) +* However since we will not be accessing invalid +* memory and zgemm promises to do nothing when +* any input dimension is 0, we don't have to guard here +* + CALL ZGEMM('No Transpose', 'Conjguate', + $ N-(I+IB)+1, IB, I-1, + $ ZONE, A(I+IB,1), LDA, A(I,1), LDA, + $ ZONE, A(I+IB,I), LDA) + END IF +* +* Now, we update the diagonal block of interest +* + CALL ZLALL2('Lower', IB, A(I,I), LDA, INFO) +* +* Update the diagonal block with the part of A above the diagonal +* + CALL ZHERK('Lower', 'No Transpose', IB, I-1, + $ ONE, A(I,1), LDA, ONE, A(I,I), LDA) +* +* Only the first iteration will have IB be different from NB +* + IB = NB + END DO + END IF + END SUBROUTINE diff --git a/lapack-netlib/SRC/zlallm_recursive.c b/lapack-netlib/SRC/zlallm_recursive.c new file mode 100644 index 0000000000..f682ccfa08 --- /dev/null +++ b/lapack-netlib/SRC/zlallm_recursive.c @@ -0,0 +1,558 @@ +#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 _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#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);} +#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)} + +/* -- 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 doublecomplex c_b1 = {1.,0.}; +static integer c__3 = 3; +static integer c_n1 = -1; +static doublereal c_b13 = 1.; + +/* > \brief \b ZLALLM_ computes the product LLH or UHU, 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 ZLALLM_( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLALLM_ computes the product L * L**H or U**H * U, 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. Regardless, the diagonal elements are explicitly */ +/* > set to be real by casting to DBLE before exit. */ +/* > */ +/* > This is the recursive form 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**H * U, */ +/* > 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 * L**H, 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 lallm */ + +/* ===================================================================== */ +/* Subroutine */ void zlallm_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 *), + zlall2_(char *, integer *, doublecomplex *, integer *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + + +/* ===================================================================== */ + + +/* 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_("ZLALLM_RECURSIVE", &i__1, (ftnlen)17); + 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, "ZLALLM_RECURSIVE", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)17, ( + ftnlen)1); + if (*n <= nx) { + zlall2_(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**H U) */ + +/* Break apart U as */ + +/* |-----------------| */ +/* 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} and U_{22} are upper triangular and U_{12} is rectangular */ + +/* This gives us our operations as */ +/* |--------------------------| |-----------------| */ +/* ut(U**H U) = | U_{11}**H 0 | | U_{11} U_{12} | */ +/* | U_{12}**H U_{22}**H | | 0 U_{22} | */ +/* |--------------------------| |-----------------| */ + +/* Thus we get */ + +/* U_{11} = U_{11}**H U_{11} */ +/* U_{12} = U_{11}**H U_{12} */ + +/* U_{22} = U_{12}**H U_{12} + U_{22}**H U_{22} */ + +/* We break these operations apart as follows */ + +/* U_{22} = U_{22}**H U_{22} (This subroutine) */ +/* U_{22} = U_{12}**H U_{12} + U_{22} (HERK) */ + +/* U_{12} = U_{11}**H U_{12} (TRMM) */ + +/* U_{11} = U_{11}**H U_{11} (This subroutine) */ + +/* Compute U_{22} */ + + i__1 = *n - k; + zlallm_recursive_(uplo, &i__1, &a[k + 1 + (k + 1) * a_dim1], lda, info); + i__1 = *n - k; + zherk_("Upper", "Conjugate", &i__1, &k, &c_b13, &a[(k + 1) * a_dim1 + + 1], lda, &c_b13, &a[k + 1 + (k + 1) * a_dim1], lda); + +/* Compute U_{12} */ + + i__1 = *n - k; + ztrmm_("Left", "Upper", "Conjugate", "Non-unit", &k, &i__1, &c_b1, &a[ + a_offset], lda, &a[(k + 1) * a_dim1 + 1], lda); + +/* Compute U_{11} */ + + zlallm_recursive_(uplo, &k, &a[a_offset], lda, info); + } else { + +/* We are computing A = lt(LL**H) */ + +/* Break apart L as */ + +/* |-----------------| */ +/* 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} and L_{22} are lower triangular and L_{21} is rectangular */ + +/* This gives us our operations as */ +/* |--------------------| |-----------------------| */ +/* lt(LL**H) = | L_{11} 0 | | L_{11}**H L_{21}**H | */ +/* | L_{21} L_{22} | | 0 L_{22}**H | */ +/* |--------------------| |-----------------------| */ + +/* Thus we get */ + +/* L_{11} = L_{11} L_{11}**H */ +/* L_{21} = L_{21} L_{11}**H */ + +/* L_{22} = L_{21} L_{21}**H + L_{22} L_{22}**H */ + +/* We break these operations apart as follows */ + +/* L_{22} = L_{22} L_{22}**H (This subroutine) */ +/* L_{22} = L_{21} L_{21}**H + L_{22} (HERK) */ + +/* L_{21} = L_{21} L_{11}**H (TRMM) */ + +/* L_{11} = L_{11} L_{11}**H (This subroutine) */ + +/* Compute L_{22} */ + + i__1 = *n - k; + zlallm_recursive_(uplo, &i__1, &a[k + 1 + (k + 1) * a_dim1], lda, info); + i__1 = *n - k; + zherk_("Lower", "No Transpose", &i__1, &k, &c_b13, &a[k + 1 + a_dim1], + lda, &c_b13, &a[k + 1 + (k + 1) * a_dim1], lda); + +/* Compute L_{21} */ + + i__1 = *n - k; + ztrmm_("Right", "Lower", "Conjugate", "Non-unit", &i__1, &k, &c_b1, & + a[a_offset], lda, &a[k + 1 + a_dim1], lda); + +/* Compute L_{11} */ + + zlallm_recursive_(uplo, &k, &a[a_offset], lda, info); + } + return; +} /* zlallm___ */ + diff --git a/lapack-netlib/SRC/zlallm_recursive.f b/lapack-netlib/SRC/zlallm_recursive.f new file mode 100644 index 0000000000..912ace6df8 --- /dev/null +++ b/lapack-netlib/SRC/zlallm_recursive.f @@ -0,0 +1,282 @@ +*> \brief \b ZLALLM_RECURSIVE computes the product LLH or UHU, 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 ZLALLM_RECURSIVE( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLALLM_RECURSIVE computes the product L * L**H or U**H * U, 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. Regardless, the diagonal elements are explicitly +*> set to be real by casting to DBLE before exit. +*> +*> This is the recursive form 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**H * U, +*> 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 * L**H, 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 lallm +* +* ===================================================================== + RECURSIVE SUBROUTINE ZLALLM_RECURSIVE( UPLO, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZONE + DOUBLE PRECISION ONE + PARAMETER ( ZONE=(1.0D+0,0.0D+0), ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I,J,NX,K + COMPLEX*16 AII,AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLALL2, ZHERK, ZTRMM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. 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( 'ZLALLM_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) * CONJG(A(1,1))) + RETURN + END IF +* +* Determine crossover point for when to bail to level2 +* + NX = ILAENV(3, "ZLALLM_RECURSIVE", UPLO, N, -1, -1, -1) + IF( N.LE.NX ) THEN + CALL ZLALL2(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**H U) +* +* Break apart U as +* +* |-----------------| +* 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} and U_{22} are upper triangular and U_{12} is rectangular +* +* This gives us our operations as +* |--------------------------| |-----------------| +* ut(U**H U) = | U_{11}**H 0 | | U_{11} U_{12} | +* | U_{12}**H U_{22}**H | | 0 U_{22} | +* |--------------------------| |-----------------| +* +* Thus we get +* +* U_{11} = U_{11}**H U_{11} +* U_{12} = U_{11}**H U_{12} +* +* U_{22} = U_{12}**H U_{12} + U_{22}**H U_{22} +* +* We break these operations apart as follows +* +* U_{22} = U_{22}**H U_{22} (This subroutine) +* U_{22} = U_{12}**H U_{12} + U_{22} (HERK) +* +* U_{12} = U_{11}**H U_{12} (TRMM) +* +* U_{11} = U_{11}**H U_{11} (This subroutine) +* +* Compute U_{22} +* + CALL ZLALLM_RECURSIVE(UPLO, N-K, A(K+1,K+1), LDA, INFO) + CALL ZHERK('Upper', 'Conjugate', N-K, K, ONE, A(1,K+1), LDA, + $ ONE, A(K+1,K+1), LDA) +* +* Compute U_{12} +* + CALL ZTRMM('Left', 'Upper', 'Conjugate', 'Non-unit', + $ K, N-K, ZONE, A, LDA, A(1,K+1), LDA) +* +* Compute U_{11} +* + CALL ZLALLM_RECURSIVE(UPLO, K, A, LDA, INFO) + ELSE +* +* We are computing A = lt(LL**H) +* +* Break apart L as +* +* |-----------------| +* 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} and L_{22} are lower triangular and L_{21} is rectangular +* +* This gives us our operations as +* |--------------------| |-----------------------| +* lt(LL**H) = | L_{11} 0 | | L_{11}**H L_{21}**H | +* | L_{21} L_{22} | | 0 L_{22}**H | +* |--------------------| |-----------------------| +* +* Thus we get +* +* L_{11} = L_{11} L_{11}**H +* L_{21} = L_{21} L_{11}**H +* +* L_{22} = L_{21} L_{21}**H + L_{22} L_{22}**H +* +* We break these operations apart as follows +* +* L_{22} = L_{22} L_{22}**H (This subroutine) +* L_{22} = L_{21} L_{21}**H + L_{22} (HERK) +* +* L_{21} = L_{21} L_{11}**H (TRMM) +* +* L_{11} = L_{11} L_{11}**H (This subroutine) +* +* Compute L_{22} +* + CALL ZLALLM_RECURSIVE(UPLO, N-K, A(K+1,K+1), LDA, INFO) + CALL ZHERK('Lower', 'No Transpose', N-K, K, + $ ONE, A(K+1,1), LDA, ONE, A(K+1,K+1), LDA) +* +* Compute L_{21} +* + CALL ZTRMM('Right', 'Lower', 'Conjugate', 'Non-unit', + $ N-K, K, ZONE, A, LDA, A(K+1,1), LDA) +* +* Compute L_{11} +* + CALL ZLALLM_RECURSIVE(UPLO, K, A, LDA, INFO) + END IF + + END SUBROUTINE